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 if ( defined $self->$col and not looks_like_number( $self->$col ) ) {
133 if ( $columns_info->{$col}->{is_nullable} ) {
134 # If nullable, default to null
137 # If cannot be null, get the default value
138 # What if cannot be null and does not have a default value? Possible?
139 $self->$col($columns_info->{$col}->{default_value});
143 elsif ( _date_or_datetime_column_type( $columns_info->{$col}->{data_type} ) ) {
144 # Set to null if an empty string (or == 0 but should not happen)
145 if ( defined $self->$col and not $self->$col ) {
146 if ( $columns_info->{$col}->{is_nullable} ) {
149 $self->$col($columns_info->{$col}->{default_value});
156 return $self->_result()->update_or_insert() ? $self : undef;
159 # Catch problems and raise relevant exceptions
160 if (ref($_) eq 'DBIx::Class::Exception') {
161 if ( $_->{msg} =~ /Cannot add or update a child row: a foreign key constraint fails/ ) {
163 # FIXME: MySQL error, if we support more DB engines we should implement this for each
164 if ( $_->{msg} =~ /FOREIGN KEY \(`(?<column>.*?)`\)/ ) {
165 Koha::Exceptions::Object::FKConstraint->throw(
166 error => 'Broken FK constraint',
167 broken_fk => $+{column}
171 elsif( $_->{msg} =~ /Duplicate entry '(.*?)' for key '(?<key>.*?)'/ ) {
172 Koha::Exceptions::Object::DuplicateID->throw(
173 error => 'Duplicate ID',
174 duplicate_id => $+{key}
177 elsif( $_->{msg} =~ /Incorrect (?<type>\w+) value: '(?<value>.*)' for column \W?(?<property>\S+)/ ) { # The optional \W in the regex might be a quote or backtick
179 my $value = $+{value};
180 my $property = $+{property};
181 $property =~ s/['`]//g;
182 Koha::Exceptions::Object::BadValue->throw(
185 property => $property =~ /(\w+\.\w+)$/ ? $1 : $property, # results in table.column without quotes or backtics
189 # Catch-all for foreign key breakages. It will help find other use cases
194 =head3 $object->delete();
196 Removes the object from storage.
199 1 if the deletion was a success
200 0 if the deletion failed
201 -1 if the object was never in storage
208 # Deleting something not in storage throws an exception
209 return -1 unless $self->_result()->in_storage();
211 # Return a boolean for succcess
212 return $self->_result()->delete() ? 1 : 0;
215 =head3 $object->set( $properties_hashref )
219 property1 => $property1,
220 property2 => $property2,
221 property3 => $propery3,
225 Enables multiple properties to be set at once
228 1 if all properties were set.
229 0 if one or more properties do not exist.
230 undef if all properties exist but a different error
231 prevents one or more properties from being set.
233 If one or more of the properties do not exist,
234 no properties will be set.
239 my ( $self, $properties ) = @_;
241 my @columns = @{$self->_columns()};
243 foreach my $p ( keys %$properties ) {
244 unless ( grep {/^$p$/} @columns ) {
245 Koha::Exceptions::Object::PropertyNotFound->throw( "No property $p for " . ref($self) );
249 return $self->_result()->set_columns($properties) ? $self : undef;
252 =head3 $object->unblessed();
254 Returns an unblessed representation of object.
261 return { $self->_result->get_columns };
264 =head3 $object->get_from_storage;
268 sub get_from_storage {
269 my ( $self, $attrs ) = @_;
270 my $stored_object = $self->_result->get_from_storage($attrs);
271 return unless $stored_object;
272 my $object_class = Koha::Object::_get_object_class( $self->_result->result_class );
273 return $object_class->_new_from_dbic($stored_object);
276 =head3 $object->TO_JSON
278 Returns an unblessed representation of the object, suitable for JSON output.
286 my $unblessed = $self->unblessed;
287 my $columns_info = Koha::Database->new->schema->resultset( $self->_type )
288 ->result_source->{_columns};
290 foreach my $col ( keys %{$columns_info} ) {
292 if ( $columns_info->{$col}->{is_boolean} )
293 { # Handle booleans gracefully
295 = ( $unblessed->{$col} )
299 elsif ( _numeric_column_type( $columns_info->{$col}->{data_type} )
300 and looks_like_number( $unblessed->{$col} )
303 # TODO: Remove once the solution for
304 # https://rt.cpan.org/Ticket/Display.html?id=119904
305 # is ported to whatever distro we support by that time
306 $unblessed->{$col} += 0;
308 elsif ( _datetime_column_type( $columns_info->{$col}->{data_type} ) ) {
310 return unless $unblessed->{$col};
311 $unblessed->{$col} = output_pref({
312 dateformat => 'rfc3339',
313 dt => dt_from_string($unblessed->{$col}, 'sql'),
321 sub _date_or_datetime_column_type {
322 my ($column_type) = @_;
330 return ( grep { $column_type eq $_ } @dt_types) ? 1 : 0;
332 sub _datetime_column_type {
333 my ($column_type) = @_;
340 return ( grep { $column_type eq $_ } @dt_types) ? 1 : 0;
343 sub _numeric_column_type {
344 # TODO: Remove once the solution for
345 # https://rt.cpan.org/Ticket/Display.html?id=119904
346 # is ported to whatever distro we support by that time
347 my ($column_type) = @_;
349 my @numeric_types = (
361 return ( grep { $column_type eq $_ } @numeric_types) ? 1 : 0;
366 my $object_for_api = $object->to_api(
387 Returns a representation of the object, suitable for API output.
392 my ( $self, $params ) = @_;
393 my $json_object = $self->TO_JSON;
395 my $to_api_mapping = $self->to_api_mapping;
397 # Rename attributes if there's a mapping
398 if ( $self->can('to_api_mapping') ) {
399 foreach my $column ( keys %{ $self->to_api_mapping } ) {
400 my $mapped_column = $self->to_api_mapping->{$column};
401 if ( exists $json_object->{$column}
402 && defined $mapped_column )
405 $json_object->{$mapped_column} = delete $json_object->{$column};
407 elsif ( exists $json_object->{$column}
408 && !defined $mapped_column )
411 delete $json_object->{$column};
416 my $embeds = $params->{embed};
419 foreach my $embed ( keys %{$embeds} ) {
421 my $next = $embeds->{$curr}->{children};
423 my $children = $self->$curr;
425 if ( defined $children and ref($children) eq 'ARRAY' ) {
427 $self->_handle_to_api_child(
428 { child => $_, next => $next, curr => $curr } )
430 $json_object->{$curr} = \@list;
433 $json_object->{$curr} = $self->_handle_to_api_child(
434 { child => $children, next => $next, curr => $curr } );
444 =head3 to_api_mapping
446 my $mapping = $object->to_api_mapping;
448 Generic method that returns the attribute name mappings required to
449 render the object on the API.
451 Note: this only returns an empty I<hashref>. Each class should have its
452 own mapping returned.
460 =head3 from_api_mapping
462 my $mapping = $object->from_api_mapping;
464 Generic method that returns the attribute name mappings so the data that
465 comes from the API is correctly renamed to match what is required for the DB.
469 sub from_api_mapping {
472 my $to_api_mapping = $self->to_api_mapping;
474 unless ( $self->{_from_api_mapping} ) {
475 while (my ($key, $value) = each %{ $to_api_mapping } ) {
476 $self->{_from_api_mapping}->{$value} = $key
481 return $self->{_from_api_mapping};
486 my $object = Koha::Object->new_from_api;
487 my $object = Koha::Object->new_from_api( $attrs );
489 Creates a new object, mapping the API attribute names to the ones on the DB schema.
494 my ( $class, $params ) = @_;
496 my $self = $class->new;
497 return $self->set_from_api( $params );
502 my $object = Koha::Object->new(...);
503 $object->set_from_api( $attrs )
505 Sets the object's attributes mapping API attribute names to the ones on the DB schema.
510 my ( $self, $from_api_params ) = @_;
512 return $self->set( $self->attributes_from_api( $from_api_params ) );
515 =head3 attributes_from_api
517 my $attributes = attributes_from_api( $params );
519 Returns the passed params, converted from API naming into the model.
523 sub attributes_from_api {
524 my ( $self, $from_api_params ) = @_;
526 my $from_api_mapping = $self->from_api_mapping;
529 my $columns_info = $self->_result->result_source->columns_info;
531 while (my ($key, $value) = each %{ $from_api_params } ) {
532 my $koha_field_name =
533 exists $from_api_mapping->{$key}
534 ? $from_api_mapping->{$key}
537 if ( $columns_info->{$koha_field_name}->{is_boolean} ) {
538 # TODO: Remove when D8 is formally deprecated
539 # Handle booleans gracefully
540 $value = ( $value ) ? 1 : 0;
542 elsif ( _date_or_datetime_column_type( $columns_info->{$koha_field_name}->{data_type} ) ) {
544 $value = dt_from_string($value, 'rfc3339');
547 Koha::Exceptions::BadParameter->throw( parameter => $key );
551 $params->{$koha_field_name} = $value;
557 =head3 $object->unblessed_all_relateds
559 my $everything_into_one_hashref = $object->unblessed_all_relateds
561 The unblessed method only retrieves column' values for the column of the object.
562 In a *few* cases we want to retrieve the information of all the prefetched data.
566 sub unblessed_all_relateds {
570 my $related_resultsets = $self->_result->{related_resultsets} || {};
571 my $rs = $self->_result;
572 while ( $related_resultsets and %$related_resultsets ) {
573 my @relations = keys %{ $related_resultsets };
575 my $relation = $relations[0];
576 $rs = $rs->related_resultset($relation)->get_cache;
577 $rs = $rs->[0]; # Does it makes sense to have several values here?
578 my $object_class = Koha::Object::_get_object_class( $rs->result_class );
579 my $koha_object = $object_class->_new_from_dbic( $rs );
580 $related_resultsets = $rs->{related_resultsets};
581 %data = ( %data, %{ $koha_object->unblessed } );
584 %data = ( %data, %{ $self->unblessed } );
588 =head3 $object->_result();
590 Returns the internal DBIC Row object
597 # If we don't have a dbic row at this point, we need to create an empty one
599 Koha::Database->new()->schema()->resultset( $self->_type() )->new({});
601 return $self->{_result};
604 =head3 $object->_columns();
606 Returns an arrayref of the table columns
613 # If we don't have a dbic row at this point, we need to create an empty one
614 $self->{_columns} ||= [ $self->_result()->result_source()->columns() ];
616 return $self->{_columns};
619 sub _get_object_class {
623 if( $type->can('koha_object_class') ) {
624 return $type->koha_object_class;
626 $type =~ s|Schema::Result::||;
632 The autoload method is used only to get and set values for an objects properties.
639 my $method = our $AUTOLOAD;
642 my @columns = @{$self->_columns()};
643 # Using direct setter/getter like $item->barcode() or $item->barcode($barcode);
644 if ( grep {/^$method$/} @columns ) {
646 $self->_result()->set_column( $method, @_ );
649 my $value = $self->_result()->get_column( $method );
654 my @known_methods = qw( is_changed id in_storage get_column discard_changes update make_column_dirty );
656 Koha::Exceptions::Object::MethodNotCoveredByTests->throw(
657 error => sprintf("The method %s->%s is not covered by tests!", ref($self), $method),
659 ) unless grep { /^$method$/ } @known_methods;
662 my $r = eval { $self->_result->$method(@_) };
664 Koha::Exceptions::Object->throw( ref($self) . "::$method generated this error: " . $@ );
671 This method must be defined in the child class. The value is the name of the DBIC resultset.
672 For example, for borrowers, the _type method will return "Borrower".
678 =head3 _handle_to_api_child
682 sub _handle_to_api_child {
683 my ($self, $args ) = @_;
685 my $child = $args->{child};
686 my $next = $args->{next};
687 my $curr = $args->{curr};
691 if ( defined $child ) {
693 Koha::Exceptions::Exception->throw( "Asked to embed $curr but its return value doesn't implement to_api" )
694 if defined $next and blessed $child and !$child->can('to_api');
696 if ( blessed $child ) {
697 $res = $child->to_api({ embed => $next });
711 Kyle M Hall <kyle@bywatersolutions.com>
713 Jonathan Druart <jonathan.druart@bugs.koha-community.org>