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
});
154 elsif ( not defined $self->$col
155 && $columns_info->{$col}->{datetime_undef_if_invalid
} )
158 $self->_result()->set_column($col => $columns_info->{$col}->{default_value
});
164 return $self->_result()->update_or_insert() ?
$self : undef;
167 # Catch problems and raise relevant exceptions
168 if (ref($_) eq 'DBIx::Class::Exception') {
170 if ( $_->{msg
} =~ /Cannot add or update a child row: a foreign key constraint fails/ ) {
172 # FIXME: MySQL error, if we support more DB engines we should implement this for each
173 if ( $_->{msg
} =~ /FOREIGN KEY \(`(?<column>.*?)`\)/ ) {
174 Koha
::Exceptions
::Object
::FKConstraint
->throw(
175 error
=> 'Broken FK constraint',
176 broken_fk
=> $+{column
}
180 elsif( $_->{msg
} =~ /Duplicate entry '(.*?)' for key '(?<key>.*?)'/ ) {
181 Koha
::Exceptions
::Object
::DuplicateID
->throw(
182 error
=> 'Duplicate ID',
183 duplicate_id
=> $+{key
}
186 elsif( $_->{msg
} =~ /Incorrect (?<type>\w+) value: '(?<value>.*)' for column \W?(?<property>\S+)/ ) { # The optional \W in the regex might be a quote or backtick
188 my $value = $+{value
};
189 my $property = $+{property
};
190 $property =~ s/['`]//g;
191 Koha
::Exceptions
::Object
::BadValue
->throw(
194 property
=> $property =~ /(\w+\.\w+)$/ ?
$1 : $property, # results in table.column without quotes or backtics
198 # Catch-all for foreign key breakages. It will help find other use cases
203 =head3 $object->update();
205 A shortcut for set + store in one call.
210 my ($self, $values) = @_;
211 return $self->set($values)->store();
214 =head3 $object->delete();
216 Removes the object from storage.
219 1 if the deletion was a success
220 0 if the deletion failed
221 -1 if the object was never in storage
228 my $deleted = $self->_result()->delete;
229 if ( ref $deleted ) {
230 my $object_class = Koha
::Object
::_get_object_class
( $self->_result->result_class );
231 $deleted = $object_class->_new_from_dbic($deleted);
236 =head3 $object->set( $properties_hashref )
240 property1 => $property1,
241 property2 => $property2,
242 property3 => $propery3,
246 Enables multiple properties to be set at once
249 1 if all properties were set.
250 0 if one or more properties do not exist.
251 undef if all properties exist but a different error
252 prevents one or more properties from being set.
254 If one or more of the properties do not exist,
255 no properties will be set.
260 my ( $self, $properties ) = @_;
262 my @columns = @
{$self->_columns()};
264 foreach my $p ( keys %$properties ) {
265 unless ( grep { $_ eq $p } @columns ) {
266 Koha
::Exceptions
::Object
::PropertyNotFound
->throw( "No property $p for " . ref($self) );
270 return $self->_result()->set_columns($properties) ?
$self : undef;
273 =head3 $object->set_or_blank( $properties_hashref )
275 $object->set_or_blank(
277 property1 => $property1,
278 property2 => $property2,
279 property3 => $propery3,
283 If not listed in $properties_hashref, the property will be set to the default
284 value defined at DB level, or nulled.
290 my ( $self, $properties ) = @_;
292 my $columns_info = $self->_result->result_source->columns_info;
294 foreach my $col ( keys %{$columns_info} ) {
296 next if exists $properties->{$col};
298 if ( $columns_info->{$col}->{is_nullable
} ) {
299 $properties->{$col} = undef;
301 $properties->{$col} = $columns_info->{$col}->{default_value
};
305 return $self->set($properties);
308 =head3 $object->unblessed();
310 Returns an unblessed representation of object.
317 return { $self->_result->get_columns };
320 =head3 $object->get_from_storage;
324 sub get_from_storage
{
325 my ( $self, $attrs ) = @_;
326 my $stored_object = $self->_result->get_from_storage($attrs);
327 return unless $stored_object;
328 my $object_class = Koha
::Object
::_get_object_class
( $self->_result->result_class );
329 return $object_class->_new_from_dbic($stored_object);
332 =head3 $object->TO_JSON
334 Returns an unblessed representation of the object, suitable for JSON output.
342 my $unblessed = $self->unblessed;
343 my $columns_info = Koha
::Database
->new->schema->resultset( $self->_type )
344 ->result_source->{_columns
};
346 foreach my $col ( keys %{$columns_info} ) {
348 if ( $columns_info->{$col}->{is_boolean
} )
349 { # Handle booleans gracefully
351 = ( $unblessed->{$col} )
355 elsif ( _numeric_column_type
( $columns_info->{$col}->{data_type
} )
356 and looks_like_number
( $unblessed->{$col} )
359 # TODO: Remove once the solution for
360 # https://rt.cpan.org/Ticket/Display.html?id=119904
361 # is ported to whatever distro we support by that time
362 $unblessed->{$col} += 0;
364 elsif ( _datetime_column_type
( $columns_info->{$col}->{data_type
} ) ) {
366 return unless $unblessed->{$col};
367 $unblessed->{$col} = output_pref
({
368 dateformat
=> 'rfc3339',
369 dt
=> dt_from_string
($unblessed->{$col}, 'sql'),
377 sub _date_or_datetime_column_type
{
378 my ($column_type) = @_;
386 return ( grep { $column_type eq $_ } @dt_types) ?
1 : 0;
388 sub _datetime_column_type
{
389 my ($column_type) = @_;
396 return ( grep { $column_type eq $_ } @dt_types) ?
1 : 0;
399 sub _numeric_column_type
{
400 # TODO: Remove once the solution for
401 # https://rt.cpan.org/Ticket/Display.html?id=119904
402 # is ported to whatever distro we support by that time
403 my ($column_type) = @_;
405 my @numeric_types = (
417 return ( grep { $column_type eq $_ } @numeric_types) ?
1 : 0;
420 =head3 prefetch_whitelist
422 my $whitelist = $object->prefetch_whitelist()
424 Returns a hash of prefetchable subs and the type they return.
428 sub prefetch_whitelist
{
432 my $relations = $self->_result->result_source->_relationships;
434 foreach my $key (keys %{$relations}) {
435 if($self->can($key)) {
436 my $result_class = $relations->{$key}->{class};
437 my $obj = $result_class->new;
439 $whitelist->{$key} = $obj->koha_object_class;
441 $whitelist->{$key} = undef;
451 my $object_for_api = $object->to_api(
472 Returns a representation of the object, suitable for API output.
477 my ( $self, $params ) = @_;
478 my $json_object = $self->TO_JSON;
480 my $to_api_mapping = $self->to_api_mapping;
482 # Rename attributes if there's a mapping
483 if ( $self->can('to_api_mapping') ) {
484 foreach my $column ( keys %{ $self->to_api_mapping } ) {
485 my $mapped_column = $self->to_api_mapping->{$column};
486 if ( exists $json_object->{$column}
487 && defined $mapped_column )
490 $json_object->{$mapped_column} = delete $json_object->{$column};
492 elsif ( exists $json_object->{$column}
493 && !defined $mapped_column )
496 delete $json_object->{$column};
501 my $embeds = $params->{embed
};
504 foreach my $embed ( keys %{$embeds} ) {
505 if ( $embed =~ m/^(?<relation>.*)_count$/
506 and $embeds->{$embed}->{is_count
} ) {
508 my $relation = $+{relation
};
509 $json_object->{$embed} = $self->$relation->count;
513 my $next = $embeds->{$curr}->{children
};
515 my $children = $self->$curr;
517 if ( defined $children and ref($children) eq 'ARRAY' ) {
519 $self->_handle_to_api_child(
520 { child
=> $_, next => $next, curr
=> $curr } )
522 $json_object->{$curr} = \
@list;
525 $json_object->{$curr} = $self->_handle_to_api_child(
526 { child
=> $children, next => $next, curr
=> $curr } );
537 =head3 to_api_mapping
539 my $mapping = $object->to_api_mapping;
541 Generic method that returns the attribute name mappings required to
542 render the object on the API.
544 Note: this only returns an empty I<hashref>. Each class should have its
545 own mapping returned.
553 =head3 from_api_mapping
555 my $mapping = $object->from_api_mapping;
557 Generic method that returns the attribute name mappings so the data that
558 comes from the API is correctly renamed to match what is required for the DB.
562 sub from_api_mapping
{
565 my $to_api_mapping = $self->to_api_mapping;
567 unless ( $self->{_from_api_mapping
} ) {
568 while (my ($key, $value) = each %{ $to_api_mapping } ) {
569 $self->{_from_api_mapping
}->{$value} = $key
574 return $self->{_from_api_mapping
};
579 my $object = Koha::Object->new_from_api;
580 my $object = Koha::Object->new_from_api( $attrs );
582 Creates a new object, mapping the API attribute names to the ones on the DB schema.
587 my ( $class, $params ) = @_;
589 my $self = $class->new;
590 return $self->set_from_api( $params );
595 my $object = Koha::Object->new(...);
596 $object->set_from_api( $attrs )
598 Sets the object's attributes mapping API attribute names to the ones on the DB schema.
603 my ( $self, $from_api_params ) = @_;
605 return $self->set( $self->attributes_from_api( $from_api_params ) );
608 =head3 attributes_from_api
610 my $attributes = attributes_from_api( $params );
612 Returns the passed params, converted from API naming into the model.
616 sub attributes_from_api
{
617 my ( $self, $from_api_params ) = @_;
619 my $from_api_mapping = $self->from_api_mapping;
622 my $columns_info = $self->_result->result_source->columns_info;
624 while (my ($key, $value) = each %{ $from_api_params } ) {
625 my $koha_field_name =
626 exists $from_api_mapping->{$key}
627 ?
$from_api_mapping->{$key}
630 if ( $columns_info->{$koha_field_name}->{is_boolean
} ) {
631 # TODO: Remove when D8 is formally deprecated
632 # Handle booleans gracefully
633 $value = ( $value ) ?
1 : 0;
635 elsif ( _date_or_datetime_column_type
( $columns_info->{$koha_field_name}->{data_type
} ) ) {
637 $value = dt_from_string
($value, 'rfc3339');
640 Koha
::Exceptions
::BadParameter
->throw( parameter
=> $key );
644 $params->{$koha_field_name} = $value;
650 =head3 $object->unblessed_all_relateds
652 my $everything_into_one_hashref = $object->unblessed_all_relateds
654 The unblessed method only retrieves column' values for the column of the object.
655 In a *few* cases we want to retrieve the information of all the prefetched data.
659 sub unblessed_all_relateds
{
663 my $related_resultsets = $self->_result->{related_resultsets
} || {};
664 my $rs = $self->_result;
665 while ( $related_resultsets and %$related_resultsets ) {
666 my @relations = keys %{ $related_resultsets };
668 my $relation = $relations[0];
669 $rs = $rs->related_resultset($relation)->get_cache;
670 $rs = $rs->[0]; # Does it makes sense to have several values here?
671 my $object_class = Koha
::Object
::_get_object_class
( $rs->result_class );
672 my $koha_object = $object_class->_new_from_dbic( $rs );
673 $related_resultsets = $rs->{related_resultsets
};
674 %data = ( %data, %{ $koha_object->unblessed } );
677 %data = ( %data, %{ $self->unblessed } );
681 =head3 $object->_result();
683 Returns the internal DBIC Row object
690 # If we don't have a dbic row at this point, we need to create an empty one
692 Koha
::Database
->new()->schema()->resultset( $self->_type() )->new({});
694 return $self->{_result
};
697 =head3 $object->_columns();
699 Returns an arrayref of the table columns
706 # If we don't have a dbic row at this point, we need to create an empty one
707 $self->{_columns
} ||= [ $self->_result()->result_source()->columns() ];
709 return $self->{_columns
};
712 sub _get_object_class
{
716 if( $type->can('koha_object_class') ) {
717 return $type->koha_object_class;
719 $type =~ s
|Schema
::Result
::||;
725 The autoload method is used only to get and set values for an objects properties.
732 my $method = our $AUTOLOAD;
735 my @columns = @
{$self->_columns()};
736 # Using direct setter/getter like $item->barcode() or $item->barcode($barcode);
737 if ( grep { $_ eq $method } @columns ) {
739 $self->_result()->set_column( $method, @_ );
742 my $value = $self->_result()->get_column( $method );
747 my @known_methods = qw( is_changed id in_storage get_column discard_changes make_column_dirty );
749 Koha
::Exceptions
::Object
::MethodNotCoveredByTests
->throw(
750 error
=> sprintf("The method %s->%s is not covered by tests!", ref($self), $method),
752 ) unless grep { $_ eq $method } @known_methods;
755 my $r = eval { $self->_result->$method(@_) };
757 Koha
::Exceptions
::Object
->throw( ref($self) . "::$method generated this error: " . $@
);
764 This method must be defined in the child class. The value is the name of the DBIC resultset.
765 For example, for borrowers, the _type method will return "Borrower".
771 =head3 _handle_to_api_child
775 sub _handle_to_api_child
{
776 my ($self, $args ) = @_;
778 my $child = $args->{child
};
779 my $next = $args->{next};
780 my $curr = $args->{curr
};
784 if ( defined $child ) {
786 Koha
::Exceptions
::Exception
->throw( "Asked to embed $curr but its return value doesn't implement to_api" )
787 if defined $next and blessed
$child and !$child->can('to_api');
789 if ( blessed
$child ) {
790 $res = $child->to_api({ embed
=> $next });
804 Kyle M Hall <kyle@bywatersolutions.com>
806 Jonathan Druart <jonathan.druart@bugs.koha-community.org>