Bug 21395: Fix creation of PO file
[koha.git] / Koha / Object.pm
blobbb2a5d8ee8acaf9dfb95bf87b4cba2d393ff8c00
1 package Koha::Object;
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>.
21 use Modern::Perl;
23 use Carp;
24 use Mojo::JSON;
25 use Scalar::Util qw( blessed looks_like_number );
26 use Try::Tiny;
28 use Koha::Database;
29 use Koha::Exceptions::Object;
30 use Koha::DateUtils;
32 =head1 NAME
34 Koha::Object - Koha Object base class
36 =head1 SYNOPSIS
38 use Koha::Object;
39 my $object = Koha::Object->new({ property1 => $property1, property2 => $property2, etc... } );
41 =head1 DESCRIPTION
43 This class must always be subclassed.
45 =head1 API
47 =head2 Class Methods
49 =cut
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.
58 =cut
60 sub new {
61 my ( $class, $attributes ) = @_;
62 my $self = {};
64 if ($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};
76 $self->{_result} =
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);
91 =cut
93 sub _new_from_dbic {
94 my ( $class, $dbic_row ) = @_;
95 my $self = {};
97 # DBIC result 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.
116 Returns:
117 $self if the store was a success
118 undef if the store failed
120 =cut
122 sub store {
123 my ($self) = @_;
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} ) {
129 # Integers
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);
139 } else {
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);
152 } else {
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} )
159 # timestamp
160 $self->_result()->set_column($col => $columns_info->{$col}->{default_value});
165 try {
166 return $self->_result()->update_or_insert() ? $self : undef;
168 catch {
169 # Catch problems and raise relevant exceptions
170 if (ref($_) eq 'DBIx::Class::Exception') {
171 warn $_->{msg};
172 if ( $_->{msg} =~ /Cannot add or update a child row: a foreign key constraint fails/ ) {
173 # FK constraints
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
189 my $type = $+{type};
190 my $value = $+{value};
191 my $property = $+{property};
192 $property =~ s/['`]//g;
193 Koha::Exceptions::Object::BadValue->throw(
194 type => $type,
195 value => $value,
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
201 $_->rethrow();
205 =head3 $object->update();
207 A shortcut for set + store in one call.
209 =cut
211 sub update {
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.
221 Returns:
222 1 if the deletion was a success
223 0 if the deletion failed
224 -1 if the object was never in storage
226 =cut
228 sub delete {
229 my ($self) = @_;
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);
236 return $deleted;
239 =head3 $object->set( $properties_hashref )
241 $object->set(
243 property1 => $property1,
244 property2 => $property2,
245 property3 => $propery3,
249 Enables multiple properties to be set at once
251 Returns:
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.
260 =cut
262 sub 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.
289 =cut
292 sub set_or_blank {
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;
303 } else {
304 $properties->{$col} = $columns_info->{$col}->{default_value};
308 return $self->set($properties);
311 =head3 $object->unblessed();
313 Returns an unblessed representation of object.
315 =cut
317 sub unblessed {
318 my ($self) = @_;
320 return { $self->_result->get_columns };
323 =head3 $object->get_from_storage;
325 =cut
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.
339 =cut
341 sub TO_JSON {
343 my ($self) = @_;
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
353 $unblessed->{$col}
354 = ( $unblessed->{$col} )
355 ? Mojo::JSON->true
356 : Mojo::JSON->false;
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} ) ) {
379 eval {
380 return unless $unblessed->{$col};
381 $unblessed->{$col} = output_pref({
382 dateformat => 'rfc3339',
383 dt => dt_from_string($unblessed->{$col}, 'sql'),
388 return $unblessed;
391 sub _date_or_datetime_column_type {
392 my ($column_type) = @_;
394 my @dt_types = (
395 'timestamp',
396 'date',
397 'datetime'
400 return ( grep { $column_type eq $_ } @dt_types) ? 1 : 0;
402 sub _datetime_column_type {
403 my ($column_type) = @_;
405 my @dt_types = (
406 'timestamp',
407 'datetime'
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 = (
421 'bigint',
422 'integer',
423 'int',
424 'mediumint',
425 'smallint',
426 'tinyint',
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 = (
440 'decimal',
441 'double precision',
442 'float'
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.
454 =cut
456 sub prefetch_whitelist {
457 my ( $self ) = @_;
459 my $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;
466 try {
467 $whitelist->{$key} = Koha::Object::_get_object_class( $obj->result_class );
468 } catch {
469 $whitelist->{$key} = undef;
474 return $whitelist;
477 =head3 to_api
479 my $object_for_api = $object->to_api(
481 [ embed => {
482 items => {
483 children => {
484 holds => {,
485 children => {
491 library => {
500 Returns a representation of the object, suitable for API output.
502 =cut
504 sub to_api {
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 )
517 # key != undef
518 $json_object->{$mapped_column} = delete $json_object->{$column};
520 elsif ( exists $json_object->{$column}
521 && !defined $mapped_column )
523 # key == undef
524 delete $json_object->{$column};
529 my $embeds = $params->{embed};
531 if ($embeds) {
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;
539 else {
540 my $curr = $embed;
541 my $next = $embeds->{$curr}->{children};
543 my $children = $self->$curr;
545 if ( defined $children and ref($children) eq 'ARRAY' ) {
546 my @list = map {
547 $self->_handle_to_api_child(
548 { child => $_, next => $next, curr => $curr } )
549 } @{$children};
550 $json_object->{$curr} = \@list;
552 else {
553 $json_object->{$curr} = $self->_handle_to_api_child(
554 { child => $children, next => $next, curr => $curr } );
562 return $json_object;
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.
575 =cut
577 sub to_api_mapping {
578 return {};
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.
588 =cut
590 sub from_api_mapping {
591 my ( $self ) = @_;
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
598 if defined $value;
602 return $self->{_from_api_mapping};
605 =head3 new_from_api
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.
612 =cut
614 sub new_from_api {
615 my ( $class, $params ) = @_;
617 my $self = $class->new;
618 return $self->set_from_api( $params );
621 =head3 set_from_api
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.
628 =cut
630 sub set_from_api {
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.
642 =cut
644 sub attributes_from_api {
645 my ( $self, $from_api_params ) = @_;
647 my $from_api_mapping = $self->from_api_mapping;
649 my $params;
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}
656 : $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} ) ) {
664 try {
665 $value = dt_from_string($value, 'rfc3339');
667 catch {
668 Koha::Exceptions::BadParameter->throw( parameter => $key );
672 $params->{$koha_field_name} = $value;
675 return $params;
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.
685 =cut
687 sub unblessed_all_relateds {
688 my ($self) = @_;
690 my %data;
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 };
695 if ( @relations ) {
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 } );
706 return \%data;
709 =head3 $object->_result();
711 Returns the internal DBIC Row object
713 =cut
715 sub _result {
716 my ($self) = @_;
718 # If we don't have a dbic row at this point, we need to create an empty one
719 $self->{_result} ||=
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
729 =cut
731 sub _columns {
732 my ($self) = @_;
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 {
741 my ( $type ) = @_;
742 return unless $type;
744 if( $type->can('koha_object_class') ) {
745 return $type->koha_object_class;
747 $type =~ s|Schema::Result::||;
748 return ${type};
751 =head3 AUTOLOAD
753 The autoload method is used only to get and set values for an objects properties.
755 =cut
757 sub AUTOLOAD {
758 my $self = shift;
760 my $method = our $AUTOLOAD;
761 $method =~ s/.*://;
763 my @columns = @{$self->_columns()};
764 # Using direct setter/getter like $item->barcode() or $item->barcode($barcode);
765 if ( grep { $_ eq $method } @columns ) {
766 if ( @_ ) {
767 $self->_result()->set_column( $method, @_ );
768 return $self;
769 } else {
770 my $value = $self->_result()->get_column( $method );
771 return $value;
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),
779 show_trace => 1
780 ) unless grep { $_ eq $method } @known_methods;
783 my $r = eval { $self->_result->$method(@_) };
784 if ( $@ ) {
785 Koha::Exceptions::Object->throw( ref($self) . "::$method generated this error: " . $@ );
787 return $r;
790 =head3 _type
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".
795 =cut
797 sub _type { }
799 =head3 _handle_to_api_child
801 =cut
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};
810 my $res;
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 });
820 else {
821 $res = $child;
825 return $res;
828 sub DESTROY { }
830 =head1 AUTHOR
832 Kyle M Hall <kyle@bywatersolutions.com>
834 Jonathan Druart <jonathan.druart@bugs.koha-community.org>
836 =cut