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( 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};
75 $self->{_result
} = $schema->resultset( $class->_type() )
79 croak
("No _type found! Koha::Object must be subclassed!")
80 unless $class->_type();
82 bless( $self, $class );
86 =head3 Koha::Object->_new_from_dbic();
88 my $object = Koha::Object->_new_from_dbic($dbic_row);
93 my ( $class, $dbic_row ) = @_;
97 $self->{_result
} = $dbic_row;
99 croak
("No _type found! Koha::Object must be subclassed!")
100 unless $class->_type();
102 croak
( "DBIC result _type " . ref( $self->{_result
} ) . " isn't of the _type " . $class->_type() )
103 unless ref( $self->{_result
} ) eq "Koha::Schema::Result::" . $class->_type();
105 bless( $self, $class );
109 =head3 $object->store();
111 Saves the object in storage.
112 If the object is new, it will be created.
113 If the object previously existed, it will be updated.
116 $self if the store was a success
117 undef if the store failed
125 return $self->_result()->update_or_insert() ?
$self : undef;
128 # Catch problems and raise relevant exceptions
129 if (ref($_) eq 'DBIx::Class::Exception') {
130 if ( $_->{msg
} =~ /Cannot add or update a child row: a foreign key constraint fails/ ) {
132 # FIXME: MySQL error, if we support more DB engines we should implement this for each
133 if ( $_->{msg
} =~ /FOREIGN KEY \(`(?<column>.*?)`\)/ ) {
134 Koha
::Exceptions
::Object
::FKConstraint
->throw(
135 error
=> 'Broken FK constraint',
136 broken_fk
=> $+{column
}
140 elsif( $_->{msg
} =~ /Duplicate entry '(.*?)' for key '(?<key>.*?)'/ ) {
141 Koha
::Exceptions
::Object
::DuplicateID
->throw(
142 error
=> 'Duplicate ID',
143 duplicate_id
=> $+{key
}
147 # Catch-all for foreign key breakages. It will help find other use cases
152 =head3 $object->delete();
154 Removes the object from storage.
157 1 if the deletion was a success
158 0 if the deletion failed
159 -1 if the object was never in storage
166 # Deleting something not in storage throws an exception
167 return -1 unless $self->_result()->in_storage();
169 # Return a boolean for succcess
170 return $self->_result()->delete() ?
1 : 0;
173 =head3 $object->set( $properties_hashref )
177 property1 => $property1,
178 property2 => $property2,
179 property3 => $propery3,
183 Enables multiple properties to be set at once
186 1 if all properties were set.
187 0 if one or more properties do not exist.
188 undef if all properties exist but a different error
189 prevents one or more properties from being set.
191 If one or more of the properties do not exist,
192 no properties will be set.
197 my ( $self, $properties ) = @_;
199 my @columns = @
{$self->_columns()};
201 foreach my $p ( keys %$properties ) {
202 unless ( grep {/^$p$/} @columns ) {
203 Koha
::Exceptions
::Object
::PropertyNotFound
->throw( "No property $p for " . ref($self) );
207 return $self->_result()->set_columns($properties) ?
$self : undef;
210 =head3 $object->unblessed();
212 Returns an unblessed representation of object.
219 return { $self->_result->get_columns };
222 =head3 $object->get_from_storage;
226 sub get_from_storage
{
227 my ( $self, $attrs ) = @_;
228 my $stored_object = $self->_result->get_from_storage($attrs);
229 my $object_class = Koha
::Object
::_get_object_class
( $self->_result->result_class );
230 return $object_class->_new_from_dbic($stored_object);
233 =head3 $object->TO_JSON
235 Returns an unblessed representation of the object, suitable for JSON output.
243 my $unblessed = $self->unblessed;
244 my $columns_info = Koha
::Database
->new->schema->resultset( $self->_type )
245 ->result_source->{_columns
};
247 foreach my $col ( keys %{$columns_info} ) {
249 if ( $columns_info->{$col}->{is_boolean
} )
250 { # Handle booleans gracefully
252 = ( $unblessed->{$col} )
256 elsif ( _numeric_column_type
( $columns_info->{$col}->{data_type
} )
257 and looks_like_number
( $unblessed->{$col} )
260 # TODO: Remove once the solution for
261 # https://rt.cpan.org/Ticket/Display.html?id=119904
262 # is ported to whatever distro we support by that time
263 $unblessed->{$col} += 0;
265 elsif ( _datetime_column_type
( $columns_info->{$col}->{data_type
} ) ) {
267 return unless $unblessed->{$col};
268 $unblessed->{$col} = output_pref
({
269 dateformat
=> 'rfc3339',
270 dt
=> dt_from_string
($unblessed->{$col}, 'sql'),
278 sub _datetime_column_type
{
279 my ($column_type) = @_;
286 return ( grep { $column_type eq $_ } @dt_types) ?
1 : 0;
289 sub _numeric_column_type
{
290 # TODO: Remove once the solution for
291 # https://rt.cpan.org/Ticket/Display.html?id=119904
292 # is ported to whatever distro we support by that time
293 my ($column_type) = @_;
295 my @numeric_types = (
307 return ( grep { $column_type eq $_ } @numeric_types) ?
1 : 0;
310 =head3 $object->unblessed_all_relateds
312 my $everything_into_one_hashref = $object->unblessed_all_relateds
314 The unblessed method only retrieves column' values for the column of the object.
315 In a *few* cases we want to retrieve the information of all the prefetched data.
319 sub unblessed_all_relateds
{
323 my $related_resultsets = $self->_result->{related_resultsets
} || {};
324 my $rs = $self->_result;
325 while ( $related_resultsets and %$related_resultsets ) {
326 my @relations = keys %{ $related_resultsets };
328 my $relation = $relations[0];
329 $rs = $rs->related_resultset($relation)->get_cache;
330 $rs = $rs->[0]; # Does it makes sense to have several values here?
331 my $object_class = Koha
::Object
::_get_object_class
( $rs->result_class );
332 my $koha_object = $object_class->_new_from_dbic( $rs );
333 $related_resultsets = $rs->{related_resultsets
};
334 %data = ( %data, %{ $koha_object->unblessed } );
337 %data = ( %data, %{ $self->unblessed } );
341 =head3 $object->_result();
343 Returns the internal DBIC Row object
350 # If we don't have a dbic row at this point, we need to create an empty one
352 Koha
::Database
->new()->schema()->resultset( $self->_type() )->new({});
354 return $self->{_result
};
357 =head3 $object->_columns();
359 Returns an arrayref of the table columns
366 # If we don't have a dbic row at this point, we need to create an empty one
367 $self->{_columns
} ||= [ $self->_result()->result_source()->columns() ];
369 return $self->{_columns
};
372 sub _get_object_class
{
376 if( $type->can('koha_object_class') ) {
377 return $type->koha_object_class;
379 $type =~ s
|Schema
::Result
::||;
385 The autoload method is used only to get and set values for an objects properties.
392 my $method = our $AUTOLOAD;
395 my @columns = @
{$self->_columns()};
396 # Using direct setter/getter like $item->barcode() or $item->barcode($barcode);
397 if ( grep {/^$method$/} @columns ) {
399 $self->_result()->set_column( $method, @_ );
402 my $value = $self->_result()->get_column( $method );
407 my @known_methods = qw( is_changed id in_storage get_column discard_changes update make_column_dirty );
409 Koha
::Exceptions
::Object
::MethodNotCoveredByTests
->throw(
410 error
=> sprintf("The method %s->%s is not covered by tests!", ref($self), $method),
412 ) unless grep { /^$method$/ } @known_methods;
415 my $r = eval { $self->_result->$method(@_) };
417 Koha
::Exceptions
::Object
->throw( ref($self) . "::$method generated this error: " . $@
);
424 This method must be defined in the child class. The value is the name of the DBIC resultset.
425 For example, for borrowers, the _type method will return "Borrower".
435 Kyle M Hall <kyle@bywatersolutions.com>
437 Jonathan Druart <jonathan.druart@bugs.koha-community.org>