File Coverage

blib/lib/OpenERP/OOM/Object/Base.pm

Criterion	Covered	Total	%
statement	26	244	10.6
branch	0	102	0.0
condition	0	6	0.0
subroutine	9	39	23.0
pod	18	18	100.0
total	53	409	12.9

package OpenERP::OOM::Object::Base;

use 5.010;
use Carp;
use Data::Dumper;
use List::MoreUtils qw/uniq/;
use Moose;
use Try::Tiny;
use Try::Tiny::Retry;
use Time::HiRes qw/usleep/;
use Switch::Plain;

extends 'Moose::Object';
with 'OpenERP::OOM::DynamicUtils';

=head1 NAME

OpenERP::OOM::Class::Base

=head1 SYNOPSYS

 my $obj = $schema->class('Name')->create(\%args);

 :say $obj->id;

 $obj->name('New name');
 $obj->update;

 $obj->delete;

=head1 DESCRIPTION

Provides a base set of properties and methods for OpenERP::OOM objects (update, delete, etc).

=head1 PROPERTIES

=head2 id

Returns the OpenERP ID of an object.

 say $obj->id;

=head2 BUILD

The BUILD method sets up the methods for the links to the attached objects.

=cut

has 'id' => (
    isa => 'Int',
    is  => 'ro',
);

sub BUILD {
    my $self = shift;

    # Add methods to follow links
    my $links = $self->meta->link;
    while (my ($name, $link) = each %$links) {
        sswitch ($link->{type}) {
            case ('single'): {
                $self->meta->add_method(
                    $name,
                    sub {
                        my $obj = shift;
                        $obj->{"_$name"} //= $obj->class->schema->link($link->{class})->retrieve($link->{args}, $obj->{$link->{key}});

                        unless ($obj->{"_$name"}) {
                            # FIXME: If $obj->{"_$name"} is undefined, we have a data integrity problem.
                            # Either the linked data is missing, or the key in the OpenERP object is missing.
                            die "Error linking to OpenERP object " . $obj->id . " of class " . ref($obj);
                        }

                        # NOTE: this only links up the object from the linked object
                        # if it has a _source attribute
                        #
                        # has _source => (is => 'rw');

                        if ($obj->{"_$name"}->can('_source')) {
                            # set the _source attribute to point back
                            # to the linked object.
                            $obj->{"_$name"}->_source($obj);
                        }

                        return $obj->{"_$name"};
                    }
                )
            }
            case ('multiple'): {
                $self->meta->add_method(
                    $name,
                    sub {
                        return $self->class->schema->link($link->{class})->retrieve_list($link->{args}, $self->{$link->{key}});
                    }
                )
            }
        }
    }
}


#-------------------------------------------------------------------------------

=head1 METHODS

=head2 update

Updates an object in OpenERP after its properties have been changed.

 $obj->name('New name');
 $obj->update;

Also allows a hashref to be passed to update multiple properties:

 $obj->update({
    name  => 'new name',
    ref   => 'new reference',
    price => 'new price',
 });

=cut

sub update {
    my $self = shift;

    if (my $update = shift) {
        while (my ($param, $value) = each %$update) {
            $self->$param($value);
        }
    }
    my $context = $self->class->_get_context(shift);

    my $object;
    foreach my $attribute ($self->dirty_attributes) {
        next if ($attribute eq 'id');
        next if ($attribute =~ '^_');

        $object->{$attribute} = $self->{$attribute};
    }

    my $relationships = $self->meta->relationship;
    while (my ($name, $rel) = each %$relationships) {
        if ($object->{$rel->{key}}) {
            sswitch ($rel->{type}) {
                case ('one2many'): {
                    delete $object->{$rel->{key}};  # Don't update one2many relationships
                }
                case ('many2many'): {
                    $object->{$rel->{key}} = [[6,0,$object->{$rel->{key}}]];
                }
            }
        }
    }

    # Force Str parameters to be object type RPC::XML::string
    foreach my $attribute ($self->meta->get_all_attributes) {
        if (exists $object->{$attribute->name}) {
            $object->{$attribute->name} = $self->prepare_attribute_for_send($attribute->type_constraint, $object->{$attribute->name});
        }
    }

    $self->class->_with_retries(sub {
        $self->class->schema->client->update($self->model, $self->id, $object, $context);
    });
    $self->refresh;

    return $self;
}

#-------------------------------------------------------------------------------

=head2 update_single

Updates OpenERP with a single property of an object.

 $obj->name('New name');
 $obj->status('Active');

 $obj->update_single('name');  # Only the 'name' property is updated

=cut

sub update_single {
    my ($self, $property) = @_;
    my $value = $self->{$property};

    # Check to see if the property is the key to a many2many relationship
    my $relationships = $self->meta->relationship;
    my ($key) = grep { $relationships->{$_}->{key} eq $property } keys %$relationships;
    if($key)
    {
        my $rel = $relationships->{$key};
        if ($rel->{type} eq 'many2many') {
            $value = [[6,0,$value]];
        }
    }

    # Force Str parameters to be object type RPC::XML::string
    foreach my $attribute ($self->meta->get_all_attributes) {
        if ($attribute->name eq $property) {
            $value = $self->prepare_attribute_for_send($attribute->type_constraint, $value);
        }
    }

    $self->class->schema->client->update($self->model, $self->id, {$property => $value});
    return $self;
}

#-------------------------------------------------------------------------------

=head2 refresh

Reloads an object's properties from OpenERP.

 $obj->refresh;

=cut

sub refresh {
    my $self = shift;

    my $new = $self->class->retrieve($self->id);

    foreach my $attribute ($self->meta->get_all_attributes) {
        my $name = $attribute->name;
        $self->{$name} = ($new->$name);
    }
    $self->mark_all_clean; # reset the dirty attribute

    return $self;
}


#-------------------------------------------------------------------------------

=head2 delete

Deletes an object from OpenERP.

 my $obj = $schema->class('Partner')->retrieve(60);
 $obj->delete;

=cut

sub delete {
    my $self = shift;

    $self->class->schema->client->delete($self->model, $self->id);
}

sub _copy
{
    my $self = shift;

    my $id = $self->class->schema->client->copy($self->model, $self->id);
    # now load the new invoice and return it
    return $id;
}

=head2 copy

Clone the current object, returning the new object.

This is equivalent to pressing duplicate in the OpenERP user interface.

=cut

sub copy
{
    my ($self, @args) = @_;
    my $args = shift;
    my $id = $self->_copy;
    # passing args through allows for field refinement.
    my $clone = $self->class->retrieve($id, @args);
    return $clone;
}

#-------------------------------------------------------------------------------

=head2 print

This is a debug method.

=cut

sub print {
    my $self = shift;

    say "Print called";
}


#-------------------------------------------------------------------------------

=head2 real_create_related

This actually does the create related via OpenERP.

I'm not sure in what scenarios you should use it versus the scenario's you
shouldn't.  Suck it and see.

It will create calls like this,

# DEBUG_RPC:rpc.request:('execute', 'db', 1, '*', ('stock.partial.picking', 'write', [1], {'product_moves_out': [(0, 0, {'prodlot_id': False, 'product_id': 16, 'product_uom': 1, 'quantity': 10.0})]}, {'lang': 'en_GB', 'search_default_available': 1, 'project_id': False, 'tz': False, '__last_update': {'stock.partial.picking,1': False}, 'active_model': 'ir.ui.menu', 'section_id': False, 'contact_display': 'partner_address', 'active_ids': [3], 'active_id': 316}))

Note that it will not return the object created.

=cut

sub real_create_related
{
    my $self = shift;
    my $relation_name = shift;
    my $object = shift;
    my $context = $self->class->_get_context(shift);

    # find relationship class
    my $class = $self->relationship_class($relation_name);
    my $data = $class->_collapse_data_to_ids($object);

    $self->class->schema->client->update($self->model, $self->id, {$relation_name => [[ 0, 0, $data ]]}, $context);

    # FIXME: need to check what happens to existing data
    # how do you add multiple objects ?
    return;
}

=head2 create_related

Creates a related or linked object.

 $obj->create_related('address',{
     street   => 'Drury Lane',
     postcode => 'CV21 3DE',
 });

=cut

sub create_related {
    my ($self, $relation_name, $object) = @_;

    ### Creating related object
    ### $relation_name
    ### with initial data:
    ### $object
    my $created_obj;

    if (my $relation = $self->meta->relationship->{$relation_name}) {
        sswitch ($relation->{type}) {
            case ('one2many'): {
                my $class = $self->meta->name;
                if ($class =~ m/(.*?)::(\w+)$/) {
                    my ($base, $name) = ($1, $2);
                    my $related_class = $base . "::" . $relation->{class};

                    $self->ensure_class_loaded($related_class);
                    my $related_meta = $related_class->meta->relationship;

                    my $far_end_relation;
                    REL: for my $key (keys %$related_meta) {
                        my $value = $related_meta->{$key};
                        if ($value->{class} eq $name) {
                            $far_end_relation = $key;
                            last REL;
                        }
                    }

                    if ($far_end_relation) {
                        my $foreign_key = $related_meta->{$far_end_relation}->{key};

                        ### Far end relation exists
                        $created_obj = $self->class->schema->class($relation->{class})->create({
                            %$object,
                            $foreign_key => $self->id,
                        });

                        $self->refresh;
                    } else {
                        my $new_object = $self->class->schema->class($relation->{class})->create($object);

                        $created_obj = $new_object;
                        $self->refresh;

                        unless (grep {$new_object->id} @{$self->{$relation->{key}}}) {
                            push @{$self->{$relation->{key}}}, $new_object->id;
                            $self->update;
                        }
                    }
                }
            }
            case ('many2many'): {
                say "create_related many2many";
            }
            case ('many2one'): {
                say "create_related many2one";
            }
        }
    } elsif ($relation = $self->meta->link->{$relation_name}) {
        sswitch ($relation->{type}) {
            case ('single'): {
                ### Creating linked object
                try {
                    my $id = $self->class->schema->link($relation->{class})->create($relation->{args}, $object);
                    $created_obj = $id;
                    ### Linked object created with key $id
                    $self->{$relation->{key}} = $id;
                    $self->update_single($relation->{key});
                    undef $self->{"_$relation_name"};
                } catch {
                    die "Error creating linked object: $_[0]";
                };
            }
            case ('multiple'): {
                say "create_linked multiple";
            }
        }
    }
    else {
        croak "Can not find relation $relation_name";
    }
    return $created_obj if $created_obj;
}

sub _id
{
    my $val = shift;
    return ref $val ? $val->id : $val;
}

=head2 find_related

Finds a property related to the current object.

    my $line = $po->find_related('order_lines', [ 'id', '=', 1 ]);

This only works with relationships to OpenERP objects (i.e. not DBIC) and
to one2many relationships where the other side of the relationship has a field
pointing back to the object you are searching from.

In any other case the method will croak.

If the search criteria return more than one result it will whine.

=cut

sub find_related {
    my ($self) = shift;
    my @results = $self->search_related(@_);
    if(scalar @results > 1)
    {
        # should this just croak?
        carp 'find_related returned more than 1 result';
    }
    if(@results)
    {
        return $results[0];
    }
}

=head2 relationship_class

Returns the OpenERP::OOM::Class object for the relationship passed in.

Obviously this only works for the OpenERP relationships.  It will croak
if you ask for a relationship to a DBIC object.

=cut

sub relationship_class
{
    my ($self, $relationship) = @_;
    if (my $relation = $self->meta->relationship->{$relationship}) {
        my $type = $relation->{type};
        croak 'Cannot get a class for a DBIC relationship' if $type eq 'single'
                                                            || $type eq 'multiple';
        my $class = $relation->{class};
        return $self->class->schema->class($class);
    }
    croak "Unable to find relation $relationship";
}

=head2 search_related

Searches for objects of a relation associated with this object.

    my @lines = $po->search_related('order_lines', [ 'state', '=', 'draft' ]);

This only works with relationships to OpenERP objects (i.e. not DBIC) and
to one2many relationships where the other side of the relationship has a field
pointing back to the object you are searching from.

In any other case the method will croak.

=cut

sub search_related {
    my ($self, $relation_name, @search) = @_;

    # find the relation details and add it to the search criteria.
    if (my $relation = $self->meta->relationship->{$relation_name}) {
        sswitch ($relation->{type}) {
            case ('one2many'): {
                my $class = $self->meta->name;
                if ($class =~ m/(.*?)::(\w+)$/) {
                    my ($base, $name) = ($1, $2);
                    my $related_class = $self->class->schema->class($relation->{class});
                    my $related_meta = $related_class->object->meta->relationship;

                    my $far_end_relation;
                    REL: for my $key (keys %$related_meta) {
                        my $value = $related_meta->{$key};
                        if ($value->{class} eq $name) {
                            $far_end_relation = $key;
                            last REL;
                        }
                    }

                    if ($far_end_relation) {

                        my $foreign_key = $related_meta->{$far_end_relation}->{key};

                        push @search, [ $foreign_key, '=', $self->id ];
                        return $related_class->search(@search);

                    } else {
                        # well, perhaps we could fix this, but I can't be bothered at the moment.
                        croak 'Unable to search_related without relationship back';
                    }
                }
            }
            case ('many2many'): {
                croak 'Unable to search_related many2many relationships';
            }
            case ('many2one'): {
                croak 'Unable to search_related many2one relationships';
            }
        }
    } elsif ($relation = $self->meta->link->{$relation_name}) {
        croak 'Unable to search_related outside NonOpenERP';
    }

    croak 'Unable to search_related'; # beat up the lame programmer who did this.
}


#-------------------------------------------------------------------------------

=head2 add_related

Adds a related or linked object to a one2many, many2many, or multiple relationship.

 my $partner  = $schema->class('Partner')->find(...);
 my $category = $schema->class('PartnerCategory')->find(...);

 $partner->add_related('category', $category);

=cut

sub add_related {
    my ($self, $relation_name, $object) = @_;

    if (my $relation = $self->meta->relationship->{$relation_name}) {
        sswitch ($relation->{type}) {
            case ('one2many'): {
                # FIXME - is this the same process as adding a many2many relationship?
            }
            case ('many2many'): {
                push @{$self->{$relation->{key}}}, _id($object);
                $self->{$relation->{key}} = [uniq @{$self->{$relation->{key}}}];
                $self->update_single($relation->{key});
            }
        }
    } elsif ($relation = $self->meta->link->{$relation_name}) {
        sswitch ($relation->{type}) {
            case ('multiple'): {
                # FIXME - handle linked as well as related objects
            }
        }
    }
}


#-------------------------------------------------------------------------------

=head2 set_related

Like the DBIx::Class set_related.  Sets up a link to a related object.

=cut

sub set_related {
    my ($self, $relation_name, $object) = @_;

    if (my $relation = $self->meta->relationship->{$relation_name}) {
        sswitch ($relation->{type}) {
            case ('many2one'): {
                $self->{$relation->{key}} = $object ? _id($object) : undef;
                $self->update_single($relation->{key});
            }
            case ('many2many'): {
                my @array;
                if($object)
                {
                    if(ref $object eq 'ARRAY')
                    {
                        @array = map { _id($_) } @$object;
                    }
                    else
                    {
                        push @array, _id($object);
                    }
                }
                $self->{$relation->{key}} = \@array;
                $self->update_single($relation->{key});
            }
            default: {
                carp "Cannot use set_related() on a $_ relationship";
            }
        }
    } else {
        carp "Relation '$relation_name' does not exist!";
    }
}

=head2 execute_workflow

Performs an exec_workflow in OpenERP.

    $self->execute_workflow('purchase_confirm');

Is likely to translate to something like this,

    # DEBUG_RPC:rpc.request:('exec_workflow', 'db', 1, '*', ('purchase.order', 'purchase_confirm', 24))

The 24 is the id of the object.

=cut

sub execute_workflow
{
    my ($self, $workflow) = @_;

    retry
    {
        $self->class->schema->client->object_exec_workflow($workflow, $self->model, $self->id);
    }
    retry_if {/current transaction is aborted, commands ignored until end of transaction block/}
    catch
    {
        die $_; # rethrow the unhandled exception
    };
}

=head2 execute

Performs an execute in OpenERP.

    $self->execute('action_process');

Is likely to translate to something like this,

    # DEBUG_RPC:rpc.request:('execute', 'gooner', 1, '*', ('stock.picking', 'action_process', [26], {'lang': 'en_GB', 'search_default_available': 1, 'active_ids': [316], 'tz': False, 'active_model': 'ir.ui.menu', 'section_id': False, 'contact_display': 'partner_address', 'project_id': False, 'active_id': 316}))

The 26 is the id of the object.

=cut

sub execute
{
    my $self   = shift;
    my $action = shift;
    my @params = @_;

    my @args = ($action, $self->model, [$self->id], @params);
    my $retval;
    $self->class->_with_retries(sub {
        $retval = $self->class->schema->client->object_execute(@args);
    });
    return $retval;
}

=head2 executex

Similar to execute but it allows you to specify any number of parameters.

Primarily created to prevent any compatibility problems with other callers.
Although I'm not entirely sure if there are any.

    $self->executex('add_invoices_to_payment', [1,2], [3,4]);

Translates roughly to

    execute_kw(..., 'payment.order', 'add_invoices_to_payment', [5], [1, 2], [3, 4])

Stick a hash on the end of the list of params to pass a context object.

=cut

sub executex
{
    my ($self, $action, @rest) = @_;

    my @args = ($action, $self->model, [$self->id]);
    push @args, @rest if @rest;
    my $retval;
    $self->class->_with_retries(sub {
        $retval = $self->class->schema->client->object_execute(@args);
    });
    return $retval;
}

=head2 get_report

To print a purchase order we need to send a report, then get it, then display it, then print it (and you don't want to know about all the traffic behind the scenes...)

The first step looks like this:

    # DEBUG_RPC:rpc.request:('report', 'aquarius_openerp_jj_staging', 1, '*', (u'purchase.quotation', [1], {'model': u'purchase.order', 'id': 1, 'report_type': u'pdf'}, {'lang': u'en_GB', 'active_ids': [1], 'tz': False, 'active_model': u'purchase.order', 'section_id': False, 'search_default_draft': 1, 'project_id': False, 'active_id': 1}))

=cut

sub get_report
{
    my $self = shift;
    my $report_id = shift;

    my $id = $self->class->schema->client->report_report($report_id, $self->id,
            {
                model       => $self->model,
                id          => $self->id,
                report_type => 'pdf',
            }, @_);

    # the report_report function returns only a report id, which is all we need to pass to the next function call
    # but report_report_get don't work first time (?!) so we need to call it recursively until with get an answer
    my $data;
    while(!$data)
    {
        $data = $self->class->schema->client->report_report_get($id);
        sleep 1;
    }
    return $data;
}


1;