Koha/Koha/Objects.pm

package Koha::Objects;

# Copyright ByWater Solutions 2014
#
# This file is part of Koha.
#
# Koha is free software; you can redistribute it and/or modify it
# under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 3 of the License, or
# (at your option) any later version.
#
# Koha is distributed in the hope that it will be useful, but
# WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with Koha; if not, see <http://www.gnu.org/licenses>.

use Modern::Perl;

use Carp;
use List::MoreUtils qw( none );
use Class::Inspector;

use Koha::Database;
use Koha::Exceptions::Object;
use Koha::DateUtils qw( dt_from_string );

=head1 NAME

Koha::Objects - Koha Object set base class

=head1 SYNOPSIS

    use Koha::Objects;
    my @objects = Koha::Objects->search({ borrowernumber => $borrowernumber});

=head1 DESCRIPTION

This class must be subclassed.

=head1 API

=head2 Class Methods

=cut

=head3 Koha::Objects->new();

my $object = Koha::Objects->new();

=cut

sub new {
    my ($class) = @_;
    my $self = {};

    bless( $self, $class );
}

=head3 Koha::Objects->_new_from_dbic();

my $object = Koha::Objects->_new_from_dbic( $resultset );

=cut

sub _new_from_dbic {
    my ( $class, $resultset ) = @_;
    my $self = { _resultset => $resultset };

    bless( $self, $class );
}

=head3 Koha::Objects->find();

Similar to DBIx::Class::ResultSet->find this method accepts:
    \%columns_values | @pk_values, { key => $unique_constraint, %attrs }?
Strictly speaking, columns_values should only refer to columns under an
unique constraint.

It returns undef if no results were found

my $object = Koha::Objects->find( { col1 => $val1, col2 => $val2 } );
my $object = Koha::Objects->find( $id );
my $object = Koha::Objects->find( $idpart1, $idpart2, $attrs ); # composite PK

=cut

sub find {
    my ( $self, @pars ) = @_;

    my $object;

    unless (!@pars || none { defined($_) } @pars) {
        my $result = $self->_resultset()->find(@pars);
        if ($result) {
            $object = $self->object_class()->_new_from_dbic($result);
        }
    }

    return $object;
}

=head3 Koha::Objects->find_or_create();

my $object = Koha::Objects->find_or_create( $attrs );

=cut

sub find_or_create {
    my ( $self, $params ) = @_;

    my $result = $self->_resultset->find_or_create($params);

    return unless $result;

    my $object = $self->object_class->_new_from_dbic($result);

    return $object;
}

=head3 search

    # list context
    my @objects = Koha::Objects->search([$params, $attributes]);
    # scalar context
    my $objects = Koha::Objects->search([$params, $attributes]);
    while (my $object = $objects->next) {
        do_stuff($object);
    }

This B<instantiates> the I<Koha::Objects> class, and generates a resultset
based on the query I<$params> and I<$attributes> that are passed (like in DBIC).

In B<list context> it returns an array of I<Koha::Object> objects.
In B<scalar context> it returns an iterator.

=cut

sub search {
    my ( $self, $params, $attributes ) = @_;

    if (wantarray) {
        my @dbic_rows = $self->_resultset()->search($params, $attributes);

        return $self->_wrap(@dbic_rows);

    }
    else {
        my $class = ref($self) ? ref($self) : $self;
        my $rs = $self->_resultset()->search($params, $attributes);

        return $class->_new_from_dbic($rs);
    }
}

=head3 search_related

    my @objects = Koha::Objects->search_related( $rel_name, $cond?, \%attrs? );
    my $objects = Koha::Objects->search_related( $rel_name, $cond?, \%attrs? );

Searches the specified relationship, optionally specifying a condition and attributes for matching records.

=cut

sub search_related {
    my ( $self, $rel_name, @params ) = @_;

    return if !$rel_name;
    if (wantarray) {
        my @dbic_rows = $self->_resultset()->search_related($rel_name, @params);
        return if !@dbic_rows;
        my $object_class = _get_objects_class( $dbic_rows[0]->result_class );

        eval "require $object_class";
        return _wrap( $object_class, @dbic_rows );

    } else {
        my $rs = $self->_resultset()->search_related($rel_name, @params);
        return if !$rs;
        my $object_class = _get_objects_class( $rs->result_class );

        eval "require $object_class";
        return _new_from_dbic( $object_class, $rs );
    }
}

=head3 delete

=cut

sub delete {
    my ($self) = @_;

    if ( Class::Inspector->function_exists( $self->object_class, 'delete' ) ) {
        my $objects_deleted;
        $self->_resultset->result_source->schema->txn_do( sub {
            $self->reset; # If we iterated already over the set
            while ( my $o = $self->next ) {
                $o->delete;
                $objects_deleted++;
            }
        });
        return $objects_deleted;
    }

    return $self->_resultset->delete;
}

=head3 update

    my $objects = Koha::Objects->new; # or Koha::Objects->search
    $objects->update( $fields, [ { no_triggers => 0/1 } ] );

This method overloads the DBIC inherited one so if code-level triggers exist
(through the use of an overloaded I<update> or I<store> method in the Koha::Object
based class) those are called in a loop on the resultset.

If B<no_triggers> is passed and I<true>, then the DBIC update method is called
directly. This feature is important for performance, in cases where no code-level
triggers should be triggered. The developer will explicitly ask for this and QA should
catch wrong uses as well.

=cut

sub update {
    my ($self, $fields, $options) = @_;

    Koha::Exceptions::Object::NotInstantiated->throw(
        method => 'update',
        class  => $self
    ) unless ref $self;

    my $no_triggers = $options->{no_triggers};

    if (
        !$no_triggers
        && ( Class::Inspector->function_exists( $self->object_class, 'update' )
          or Class::Inspector->function_exists( $self->object_class, 'store' ) )
      )
    {
        my $objects_updated;
        $self->_resultset->result_source->schema->txn_do( sub {
            while ( my $o = $self->next ) {
                $o->update($fields);
                $objects_updated++;
            }
        });
        return $objects_updated;
    }

    return $self->_resultset->update($fields);
}

=head3 filter_by_last_update

my $filtered_objects = $objects->filter_by_last_update

days exclusive
from inclusive
to   inclusive

=cut

sub filter_by_last_update {
    my ( $self, $params ) = @_;
    my $timestamp_column_name = $params->{timestamp_column_name} || 'timestamp';
    my $conditions;
    Koha::Exceptions::MissingParameter->throw(
        "Missing mandatory parameter: days or from or to")
      unless exists $params->{days}
          or exists $params->{from}
          or exists $params->{to};

    my $dtf = Koha::Database->new->schema->storage->datetime_parser;
    if ( exists $params->{days} ) {
        $conditions->{'<'} = $dtf->format_date( dt_from_string->subtract( days => $params->{days} ) );
    }
    if ( exists $params->{from} ) {
        my $from = ref($params->{from}) ? $params->{from} : dt_from_string($params->{from});
        $conditions->{'>='} = $dtf->format_date( $from );
    }
    if ( exists $params->{to} ) {
        my $to = ref($params->{to}) ? $params->{to} : dt_from_string($params->{to});
        $conditions->{'<='} = $dtf->format_date( $to );
    }

    return $self->_resultset->search(
        {
            $timestamp_column_name => $conditions
        }
    );
}

=head3 single

my $object = Koha::Objects->search({}, { rows => 1 })->single

Returns one and only one object that is part of this set.
Returns undef if there are no objects found.

This is optimal as it will grab the first returned result without instantiating
a cursor.

See:
http://search.cpan.org/dist/DBIx-Class/lib/DBIx/Class/Manual/Cookbook.pod#Retrieve_one_and_only_one_row_from_a_resultset

=cut

sub single {
    my ($self) = @_;

    my $single = $self->_resultset()->single;
    return unless $single;

    return $self->object_class()->_new_from_dbic($single);
}

=head3 Koha::Objects->next();

my $object = Koha::Objects->next();

Returns the next object that is part of this set.
Returns undef if there are no more objects to return.

=cut

sub next {
    my ( $self ) = @_;

    my $result = $self->_resultset()->next();
    return unless $result;

    my $object = $self->object_class()->_new_from_dbic( $result );

    return $object;
}

=head3 Koha::Objects->last;

my $object = Koha::Objects->last;

Returns the last object that is part of this set.
Returns undef if there are no object to return.

=cut

sub last {
    my ( $self ) = @_;

    my $count = $self->_resultset->count;
    return unless $count;

    my ( $result ) = $self->_resultset->slice($count - 1, $count - 1);

    my $object = $self->object_class()->_new_from_dbic( $result );

    return $object;
}

=head3 empty

    my $empty_rs = Koha::Objects->new->empty;

Sets the resultset empty. This is handy for consistency on method returns
(e.g. if we know in advance we won't have results but want to keep returning
an iterator).

=cut

sub empty {
    my ($self) = @_;

    Koha::Exceptions::Object::NotInstantiated->throw(
        method => 'empty',
        class  => $self
    ) unless ref $self;

    $self->_resultset()->set_cache([]);

    return $self;
}

=head3 Koha::Objects->reset();

Koha::Objects->reset();

resets iteration so the next call to next() will start agein
with the first object in a set.

=cut

sub reset {
    my ( $self ) = @_;

    $self->_resultset()->reset();

    return $self;
}

=head3 Koha::Objects->as_list();

Koha::Objects->as_list();

Returns an arrayref of the objects in this set.

=cut

sub as_list {
    my ( $self ) = @_;

    my @dbic_rows = $self->_resultset()->all();

    my @objects = $self->_wrap(@dbic_rows);

    return wantarray ? @objects : \@objects;
}

=head3 Koha::Objects->unblessed

Returns an unblessed representation of objects.

=cut

sub unblessed {
    my ($self) = @_;

    return [ map { $_->unblessed } $self->as_list ];
}

=head3 Koha::Objects->get_column

Return all the values of this set for a given column

=cut

sub get_column {
    my ($self, $column_name) = @_;
    return $self->_resultset->get_column( $column_name )->all;
}

=head3 Koha::Objects->TO_JSON

Returns an unblessed representation of objects, suitable for JSON output.

=cut

sub TO_JSON {
    my ($self) = @_;

    return [ map { $_->TO_JSON } $self->as_list ];
}

=head3 Koha::Objects->to_api

Returns a representation of the objects, suitable for API output .

=cut

sub to_api {
    my ($self, $params) = @_;

    return [ map { $_->to_api($params) } $self->as_list ];
}

=head3 attributes_from_api

    my $attributes = $objects->attributes_from_api( $api_attributes );

Translates attributes from the API to DBIC

=cut

sub attributes_from_api {
    my ( $self, $attributes ) = @_;

    $self->{_singular_object} ||= $self->object_class->new();
    return $self->{_singular_object}->attributes_from_api( $attributes );
}

=head3 from_api_mapping

    my $mapped_attributes_hash = $objects->from_api_mapping;

Attributes map from the API to DBIC

=cut

sub from_api_mapping {
    my ( $self ) = @_;

    $self->{_singular_object} ||= $self->object_class->new();
    return $self->{_singular_object}->from_api_mapping;
}

=head3 prefetch_whitelist

    my $whitelist = $object->prefetch_whitelist()

Returns a hash of prefetchable subs and the type it returns

=cut

sub prefetch_whitelist {
    my ( $self ) = @_;

    $self->{_singular_object} ||= $self->object_class->new();

    $self->{_singular_object}->prefetch_whitelist;
}

=head3 Koha::Objects->_wrap

wraps the DBIC object in a corresponding Koha object

=cut

sub _wrap {
    my ( $self, @dbic_rows ) = @_;

    my @objects = map { $self->object_class->_new_from_dbic( $_ ) } @dbic_rows;

    return @objects;
}

=head3 Koha::Objects->_resultset

Returns the internal resultset or creates it if undefined

=cut

sub _resultset {
    my ($self) = @_;

    if ( ref($self) ) {
        $self->{_resultset} ||=
          Koha::Database->new()->schema()->resultset( $self->_type() );

        return $self->{_resultset};
    }
    else {
        return Koha::Database->new()->schema()->resultset( $self->_type() );
    }
}

sub _get_objects_class {
    my ( $type ) = @_;
    return unless $type;

    if( $type->can('koha_objects_class') ) {
        return $type->koha_objects_class;
    }
    $type =~ s|Schema::Result::||;
    return "${type}s";
}

=head3 columns

my @columns = Koha::Objects->columns

Return the table columns

=cut

sub columns {
    my ( $class ) = @_;
    return Koha::Database->new->schema->resultset( $class->_type )->result_source->columns;
}

=head3 AUTOLOAD

The autoload method is used call DBIx::Class method on a resultset.

Important: If you plan to use one of the DBIx::Class methods you must provide
relevant tests in t/db_dependent/Koha/Objects.t
Currently count, is_paged, pager, result_class, single and slice are covered.

=cut

sub AUTOLOAD {
    my ( $self, @params ) = @_;

    my @known_methods = qw( count is_paged pager result_class single slice );
    my $method = our $AUTOLOAD;
    $method =~ s/.*:://;


    unless ( grep { $_ eq $method } @known_methods ) {
        my $class = ref($self) ? ref($self) : $self;
        Koha::Exceptions::Object::MethodNotCoveredByTests->throw(
            error      => sprintf("The method %s->%s is not covered by tests!", $class, $method),
            show_trace => 1
        );
    }

    my $r = eval { $self->_resultset->$method(@params) };
    if ( $@ ) {
        carp "No method $method found for " . ref($self) . " " . $@;
        return
    }
    return $r;
}

=head3 _type

The _type method must be set for all child classes.
The value returned by it should be the DBIC resultset name.
For example, for holds, _type should return 'Reserve'.

=cut

sub _type { }

=head3 object_class

This method must be set for all child classes.
The value returned by it should be the name of the Koha
object class that is returned by this class.
For example, for holds, object_class should return 'Koha::Hold'.

=cut

sub object_class { }

sub DESTROY { }

=head1 AUTHOR

Kyle M Hall <kyle@bywatersolutions.com>

=cut

1;