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 or _decimal_column_type
( $columns_info->{$col}->{data_type
} )
133 # Has been passed but not a number, usually an empty string
134 my $value = $self->_result()->get_column($col);
135 if ( defined $value and not looks_like_number
( $value ) ) {
136 if ( $columns_info->{$col}->{is_nullable
} ) {
137 # If nullable, default to null
138 $self->_result()->set_column($col => undef);
140 # If cannot be null, get the default value
141 # What if cannot be null and does not have a default value? Possible?
142 $self->_result()->set_column($col => $columns_info->{$col}->{default_value
});
146 elsif ( _date_or_datetime_column_type
( $columns_info->{$col}->{data_type
} ) ) {
147 # Set to null if an empty string (or == 0 but should not happen)
148 my $value = $self->_result()->get_column($col);
149 if ( defined $value and not $value ) {
150 if ( $columns_info->{$col}->{is_nullable
} ) {
151 $self->_result()->set_column($col => undef);
153 $self->_result()->set_column($col => $columns_info->{$col}->{default_value
});
156 elsif ( not defined $self->$col
157 && $columns_info->{$col}->{datetime_undef_if_invalid
} )
160 $self->_result()->set_column($col => $columns_info->{$col}->{default_value
});
166 return $self->_result()->update_or_insert() ?
$self : undef;
169 # Catch problems and raise relevant exceptions
170 if (ref($_) eq 'DBIx::Class::Exception') {
172 if ( $_->{msg
} =~ /Cannot add or update a child row: a foreign key constraint fails/ ) {
174 # FIXME: MySQL error, if we support more DB engines we should implement this for each
175 if ( $_->{msg
} =~ /FOREIGN KEY \(`(?<column>.*?)`\)/ ) {
176 Koha
::Exceptions
::Object
::FKConstraint
->throw(
177 error
=> 'Broken FK constraint',
178 broken_fk
=> $+{column
}
182 elsif( $_->{msg
} =~ /Duplicate entry '(.*?)' for key '(?<key>.*?)'/ ) {
183 Koha
::Exceptions
::Object
::DuplicateID
->throw(
184 error
=> 'Duplicate ID',
185 duplicate_id
=> $+{key
}
188 elsif( $_->{msg
} =~ /Incorrect (?<type>\w+) value: '(?<value>.*)' for column \W?(?<property>\S+)/ ) { # The optional \W in the regex might be a quote or backtick
190 my $value = $+{value
};
191 my $property = $+{property
};
192 $property =~ s/['`]//g;
193 Koha
::Exceptions
::Object
::BadValue
->throw(
196 property
=> $property =~ /(\w+\.\w+)$/ ?
$1 : $property, # results in table.column without quotes or backtics
200 # Catch-all for foreign key breakages. It will help find other use cases
205 =head3 $object->update();
207 A shortcut for set + store in one call.
212 my ($self, $values) = @_;
213 Koha
::Exceptions
::Object
::NotInStorage
->throw unless $self->in_storage;
214 $self->set($values)->store();
217 =head3 $object->delete();
219 Removes the object from storage.
222 1 if the deletion was a success
223 0 if the deletion failed
224 -1 if the object was never in storage
231 my $deleted = $self->_result()->delete;
232 if ( ref $deleted ) {
233 my $object_class = Koha
::Object
::_get_object_class
( $self->_result->result_class );
234 $deleted = $object_class->_new_from_dbic($deleted);
239 =head3 $object->set( $properties_hashref )
243 property1 => $property1,
244 property2 => $property2,
245 property3 => $propery3,
249 Enables multiple properties to be set at once
252 1 if all properties were set.
253 0 if one or more properties do not exist.
254 undef if all properties exist but a different error
255 prevents one or more properties from being set.
257 If one or more of the properties do not exist,
258 no properties will be set.
263 my ( $self, $properties ) = @_;
265 my @columns = @
{$self->_columns()};
267 foreach my $p ( keys %$properties ) {
268 unless ( grep { $_ eq $p } @columns ) {
269 Koha
::Exceptions
::Object
::PropertyNotFound
->throw( "No property $p for " . ref($self) );
273 return $self->_result()->set_columns($properties) ?
$self : undef;
276 =head3 $object->set_or_blank( $properties_hashref )
278 $object->set_or_blank(
280 property1 => $property1,
281 property2 => $property2,
282 property3 => $propery3,
286 If not listed in $properties_hashref, the property will be set to the default
287 value defined at DB level, or nulled.
293 my ( $self, $properties ) = @_;
295 my $columns_info = $self->_result->result_source->columns_info;
297 foreach my $col ( keys %{$columns_info} ) {
299 next if exists $properties->{$col};
301 if ( $columns_info->{$col}->{is_nullable
} ) {
302 $properties->{$col} = undef;
304 $properties->{$col} = $columns_info->{$col}->{default_value
};
308 return $self->set($properties);
311 =head3 $object->unblessed();
313 Returns an unblessed representation of object.
320 return { $self->_result->get_columns };
323 =head3 $object->get_from_storage;
327 sub get_from_storage
{
328 my ( $self, $attrs ) = @_;
329 my $stored_object = $self->_result->get_from_storage($attrs);
330 return unless $stored_object;
331 my $object_class = Koha
::Object
::_get_object_class
( $self->_result->result_class );
332 return $object_class->_new_from_dbic($stored_object);
335 =head3 $object->TO_JSON
337 Returns an unblessed representation of the object, suitable for JSON output.
345 my $unblessed = $self->unblessed;
346 my $columns_info = Koha
::Database
->new->schema->resultset( $self->_type )
347 ->result_source->{_columns
};
349 foreach my $col ( keys %{$columns_info} ) {
351 if ( $columns_info->{$col}->{is_boolean
} )
352 { # Handle booleans gracefully
354 = ( $unblessed->{$col} )
358 elsif ( _numeric_column_type
( $columns_info->{$col}->{data_type
} )
359 and looks_like_number
( $unblessed->{$col} )
362 # TODO: Remove once the solution for
363 # https://github.com/perl5-dbi/DBD-mysql/issues/212
364 # is ported to whatever distro we support by that time
365 # or we move to DBD::MariaDB
366 $unblessed->{$col} += 0;
368 elsif ( _decimal_column_type
( $columns_info->{$col}->{data_type
} )
369 and looks_like_number
( $unblessed->{$col} )
372 # TODO: Remove once the solution for
373 # https://github.com/perl5-dbi/DBD-mysql/issues/212
374 # is ported to whatever distro we support by that time
375 # or we move to DBD::MariaDB
376 $unblessed->{$col} += 0.00;
378 elsif ( _datetime_column_type
( $columns_info->{$col}->{data_type
} ) ) {
380 return unless $unblessed->{$col};
381 $unblessed->{$col} = output_pref
({
382 dateformat
=> 'rfc3339',
383 dt
=> dt_from_string
($unblessed->{$col}, 'sql'),
391 sub _date_or_datetime_column_type
{
392 my ($column_type) = @_;
400 return ( grep { $column_type eq $_ } @dt_types) ?
1 : 0;
402 sub _datetime_column_type
{
403 my ($column_type) = @_;
410 return ( grep { $column_type eq $_ } @dt_types) ?
1 : 0;
413 sub _numeric_column_type
{
414 # TODO: Remove once the solution for
415 # https://github.com/perl5-dbi/DBD-mysql/issues/212
416 # is ported to whatever distro we support by that time
417 # or we move to DBD::MariaDB
418 my ($column_type) = @_;
420 my @numeric_types = (
429 return ( grep { $column_type eq $_ } @numeric_types) ?
1 : 0;
432 sub _decimal_column_type
{
433 # TODO: Remove once the solution for
434 # https://github.com/perl5-dbi/DBD-mysql/issues/212
435 # is ported to whatever distro we support by that time
436 # or we move to DBD::MariaDB
437 my ($column_type) = @_;
439 my @decimal_types = (
445 return ( grep { $column_type eq $_ } @decimal_types) ?
1 : 0;
448 =head3 prefetch_whitelist
450 my $whitelist = $object->prefetch_whitelist()
452 Returns a hash of prefetchable subs and the type they return.
456 sub prefetch_whitelist
{
460 my $relations = $self->_result->result_source->_relationships;
462 foreach my $key (keys %{$relations}) {
463 if($self->can($key)) {
464 my $result_class = $relations->{$key}->{class};
465 my $obj = $result_class->new;
467 $whitelist->{$key} = Koha
::Object
::_get_object_class
( $obj->result_class );
469 $whitelist->{$key} = undef;
479 my $object_for_api = $object->to_api(
500 Returns a representation of the object, suitable for API output.
505 my ( $self, $params ) = @_;
506 my $json_object = $self->TO_JSON;
508 my $to_api_mapping = $self->to_api_mapping;
510 # Rename attributes if there's a mapping
511 if ( $self->can('to_api_mapping') ) {
512 foreach my $column ( keys %{ $self->to_api_mapping } ) {
513 my $mapped_column = $self->to_api_mapping->{$column};
514 if ( exists $json_object->{$column}
515 && defined $mapped_column )
518 $json_object->{$mapped_column} = delete $json_object->{$column};
520 elsif ( exists $json_object->{$column}
521 && !defined $mapped_column )
524 delete $json_object->{$column};
529 my $embeds = $params->{embed
};
532 foreach my $embed ( keys %{$embeds} ) {
533 if ( $embed =~ m/^(?<relation>.*)_count$/
534 and $embeds->{$embed}->{is_count
} ) {
536 my $relation = $+{relation
};
537 $json_object->{$embed} = $self->$relation->count;
541 my $next = $embeds->{$curr}->{children
};
543 my $children = $self->$curr;
545 if ( defined $children and ref($children) eq 'ARRAY' ) {
547 $self->_handle_to_api_child(
548 { child
=> $_, next => $next, curr
=> $curr } )
550 $json_object->{$curr} = \
@list;
553 $json_object->{$curr} = $self->_handle_to_api_child(
554 { child
=> $children, next => $next, curr
=> $curr } );
565 =head3 to_api_mapping
567 my $mapping = $object->to_api_mapping;
569 Generic method that returns the attribute name mappings required to
570 render the object on the API.
572 Note: this only returns an empty I<hashref>. Each class should have its
573 own mapping returned.
581 =head3 from_api_mapping
583 my $mapping = $object->from_api_mapping;
585 Generic method that returns the attribute name mappings so the data that
586 comes from the API is correctly renamed to match what is required for the DB.
590 sub from_api_mapping
{
593 my $to_api_mapping = $self->to_api_mapping;
595 unless ( $self->{_from_api_mapping
} ) {
596 while (my ($key, $value) = each %{ $to_api_mapping } ) {
597 $self->{_from_api_mapping
}->{$value} = $key
602 return $self->{_from_api_mapping
};
607 my $object = Koha::Object->new_from_api;
608 my $object = Koha::Object->new_from_api( $attrs );
610 Creates a new object, mapping the API attribute names to the ones on the DB schema.
615 my ( $class, $params ) = @_;
617 my $self = $class->new;
618 return $self->set_from_api( $params );
623 my $object = Koha::Object->new(...);
624 $object->set_from_api( $attrs )
626 Sets the object's attributes mapping API attribute names to the ones on the DB schema.
631 my ( $self, $from_api_params ) = @_;
633 return $self->set( $self->attributes_from_api( $from_api_params ) );
636 =head3 attributes_from_api
638 my $attributes = attributes_from_api( $params );
640 Returns the passed params, converted from API naming into the model.
644 sub attributes_from_api
{
645 my ( $self, $from_api_params ) = @_;
647 my $from_api_mapping = $self->from_api_mapping;
650 my $columns_info = $self->_result->result_source->columns_info;
652 while (my ($key, $value) = each %{ $from_api_params } ) {
653 my $koha_field_name =
654 exists $from_api_mapping->{$key}
655 ?
$from_api_mapping->{$key}
658 if ( $columns_info->{$koha_field_name}->{is_boolean
} ) {
659 # TODO: Remove when D8 is formally deprecated
660 # Handle booleans gracefully
661 $value = ( $value ) ?
1 : 0;
663 elsif ( _date_or_datetime_column_type
( $columns_info->{$koha_field_name}->{data_type
} ) ) {
665 $value = dt_from_string
($value, 'rfc3339');
668 Koha
::Exceptions
::BadParameter
->throw( parameter
=> $key );
672 $params->{$koha_field_name} = $value;
678 =head3 $object->unblessed_all_relateds
680 my $everything_into_one_hashref = $object->unblessed_all_relateds
682 The unblessed method only retrieves column' values for the column of the object.
683 In a *few* cases we want to retrieve the information of all the prefetched data.
687 sub unblessed_all_relateds
{
691 my $related_resultsets = $self->_result->{related_resultsets
} || {};
692 my $rs = $self->_result;
693 while ( $related_resultsets and %$related_resultsets ) {
694 my @relations = keys %{ $related_resultsets };
696 my $relation = $relations[0];
697 $rs = $rs->related_resultset($relation)->get_cache;
698 $rs = $rs->[0]; # Does it makes sense to have several values here?
699 my $object_class = Koha
::Object
::_get_object_class
( $rs->result_class );
700 my $koha_object = $object_class->_new_from_dbic( $rs );
701 $related_resultsets = $rs->{related_resultsets
};
702 %data = ( %data, %{ $koha_object->unblessed } );
705 %data = ( %data, %{ $self->unblessed } );
709 =head3 $object->_result();
711 Returns the internal DBIC Row object
718 # If we don't have a dbic row at this point, we need to create an empty one
720 Koha
::Database
->new()->schema()->resultset( $self->_type() )->new({});
722 return $self->{_result
};
725 =head3 $object->_columns();
727 Returns an arrayref of the table columns
734 # If we don't have a dbic row at this point, we need to create an empty one
735 $self->{_columns
} ||= [ $self->_result()->result_source()->columns() ];
737 return $self->{_columns
};
740 sub _get_object_class
{
744 if( $type->can('koha_object_class') ) {
745 return $type->koha_object_class;
747 $type =~ s
|Schema
::Result
::||;
753 The autoload method is used only to get and set values for an objects properties.
760 my $method = our $AUTOLOAD;
763 my @columns = @
{$self->_columns()};
764 # Using direct setter/getter like $item->barcode() or $item->barcode($barcode);
765 if ( grep { $_ eq $method } @columns ) {
767 $self->_result()->set_column( $method, @_ );
770 my $value = $self->_result()->get_column( $method );
775 my @known_methods = qw( is_changed id in_storage get_column discard_changes make_column_dirty );
777 Koha
::Exceptions
::Object
::MethodNotCoveredByTests
->throw(
778 error
=> sprintf("The method %s->%s is not covered by tests!", ref($self), $method),
780 ) unless grep { $_ eq $method } @known_methods;
783 my $r = eval { $self->_result->$method(@_) };
785 Koha
::Exceptions
::Object
->throw( ref($self) . "::$method generated this error: " . $@
);
792 This method must be defined in the child class. The value is the name of the DBIC resultset.
793 For example, for borrowers, the _type method will return "Borrower".
799 =head3 _handle_to_api_child
803 sub _handle_to_api_child
{
804 my ($self, $args ) = @_;
806 my $child = $args->{child
};
807 my $next = $args->{next};
808 my $curr = $args->{curr
};
812 if ( defined $child ) {
814 Koha
::Exceptions
::Exception
->throw( "Asked to embed $curr but its return value doesn't implement to_api" )
815 if defined $next and blessed
$child and !$child->can('to_api');
817 if ( blessed
$child ) {
818 $res = $child->to_api({ embed
=> $next });
832 Kyle M Hall <kyle@bywatersolutions.com>
834 Jonathan Druart <jonathan.druart@bugs.koha-community.org>