source: trunk/LATMOS-Accounts/lib/LATMOS/Accounts/Bases/Sql/DataRequest.pm @ 1002

package LATMOS::Accounts::Bases::Sql::DataRequest;

use 5.010000;
use strict;
use warnings;

use LATMOS::Accounts::Utils;
use LATMOS::Accounts::Log;

our $VERSION = (q$Rev$ =~ /^Rev: (\d+) /)[0];

=head1 NAME

    LATMOS::Accounts::Bases::Sql::DataRequest

=head1 DESCRIPTION

Object to handle request forms in Link::Accounts system

=cut

=head1 FUNCTIONS

=head2 new($accreq, $id)

Instanciate a C<LATMOS::Accounts::Bases::Sql::DataRequest> object over an
existing form definition (C<$accreq>).

C<$id> is an optional DataRequest id to fetch an aready stored set of data.

=cut

sub new {
    my ($class, $accreq, $id) = @_;

    bless {
        id => $id,
        accreq => $accreq,
    }, $class
}

sub ar_id { $_[0]->{id} }

=head2 otype

=cut

sub otype { $_[0]->accreq->get_attributes('oType') }

=head2 attributes

=cut

sub attributes {
    $_[0]->accreq->get_attributes('attributes')
}

sub attribute_info {
    my ($self, $attr) = @_;
    $self->accreq->attr_info($attr);
}

sub oobject {
    my ($self) = @_;
    if (my $name = $self->object_name) {
        return $self->base->get_object($self->otype, $name);
    } else {
        return undef;
    }
}

sub set_ptr_object {
    my ($self, $ptr) = @_;

    if (ref $ptr) {
        $self->{_object_name} = $ptr->id;
    } else {
        $self->{_object_name} = $ptr;
    }
}

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

    $self->accreq->get_attributes('requireObject') ? 0 : 1;
}

# Fetch informations and cache it
sub _infos {
    my ($self) = @_;

    return $self->{_infos} if ($self->{_infos});

    my $sth = $self->accreq->db->prepare(q{
        select *, now() >= apply as due
        from request where id = ?
    });

    $sth->execute($self->ar_id);

    return $self->{_infos} = $sth->fetchrow_hashref;
}

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

    return $self->{_object_name} if ($self->{_object_name});

    return ($self->_infos || {})->{object};
}

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

    return ($self->_infos || {})->{user};
}

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

    my $user = ($self->_infos || {})->{user};
    return $self->base->get_object('user', $user);
}

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

    return ($self->_infos || {})->{apply};
}

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

    return ($self->_infos || {})->{due};
}

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

    return ($self->_infos || {})->{objrev};
}

sub register {
    my ($self, $options, %param) = @_;

    my $user = $options->{user};
    my $apply = $options->{apply};
    my $auto = $options->{auto};

    my $rev;

    if (!$self->is_for_new_object()) {
        if ($self->oobject) {
            $rev = $self->oobject->get_attributes('rev');
        } else {
            la_log(LA_ERR, "An object type %s is required", $self->otype);
            return;
        }
    }

    my $sth_req = $self->base->db->prepare(q{
        INSERT into request (name, object, "user", apply, automated, objrev)
        values (?,?,?,?,?,?)
        });
    $apply ||= scalar(localtime);
    $sth_req->execute($self->accreq->id, $self->object_name, $user, $apply,
        $auto ? 1 : 0, $rev) or return;

    my $newid = $self->base->db->last_insert_id(
        undef,undef,undef,undef,
        { sequence => 'request_id_seq'}
    ) or do {
        la_log(LA_ERR, "Cannot get new request id");
        $self->base->db->rollback;
        return;
    };

    my $sth_attr = $self->base->db->prepare(q{
        insert into request_attributes (reqid, attribute, value)
        values (?,?,?)
    });

    my $attr_count = 0;
    foreach ($self->attributes) {
        if (exists($param{$_})) {
            if ($self->oobject) {
                if (join('|', $self->oobject->get_attributes($_) || '')
                    eq
                    join('|', ref $param{$_} ? @{ $param{$_} } : $param{$_})) {
                    # No diff
                    next;
                }
            }
            if (!$param{$_}) {
                $attr_count += $sth_attr->execute($newid, $_, undef)
                    if ($self->oobject);
            } elsif(ref $param{$_}) {
                foreach my $v (@{$param{$_}}) {
                    $attr_count += $sth_attr->execute($newid, $_, $v);
                }
            } else {
                $attr_count += $sth_attr->execute($newid, $_, $param{$_});
            }
        }
    }

    if ($attr_count) {
        $self->{id} = $newid;
        $self->base->db->commit;
        $self->notify;
        # flush cache
        $self->{_infos} = undef;
        return 1;
    } else {
        la_log(LA_ERR, "Nothing to store into the request");
        $self->base->db->rollback;
        return;
    }
}

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

    if (!$self->accreq->get_attributes('notifyMail')) {
        return;
    }

    require LATMOS::Accounts::Mail;

    my $submiter = $self->user
        ? $self->base->get_object('user', $self->user)
        : undef;

    my %mail = (
        to => $self->accreq->get_attributes('notifyMail'),
        cc => ($submiter
            ? $submiter->get_attributes('mail')
            : ''),
        Subject => sprintf('New request: %s',
            $self->accreq->get_attributes('description')),
        'X-LATMOS-Reason' => 'User request',
    );

    my $text = '';

    if ($submiter) {
        $text.= "\n";
        $text .= "Request from " . $submiter->get_attributes('displayName');
        $text .= "\n";
    }

    if (my $obj = $self->oobject) {
        $text .= "For object " . $self->otype . ' ';
        $text .= $obj->id;
        if (my $dpn = $obj->get_attributes('displayName')) {
            $text .= " ($dpn)"; 
        }
        $text .= "\n\n";
    }

    my %vals = $self->get_values;
    foreach my $attr ($self->attributes) {
        if (exists($vals{$attr})) {
            foreach (ref $vals{$attr} ? @{ $vals{$attr} } : $vals{$attr}) {
                $text .= "$attr: $_\n";
            }
        }
    }

    $text .= "\n\n";
    $text .= "To apply: " . $self->apply;

    my $lamail = LATMOS::Accounts::Mail->new(
        $self->base->la,
        \$text,
    );


    if ($lamail->process(
        {}, # no variables
        \%mail,
        )) {
        la_log(LA_NOTICE, "Request mail sent to %s", $mail{to});
    }
}

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

    my $sth_f = $self->base->db->prepare(q{
        select attribute, value from request_attributes where reqid = ?
            order by attribute
    });

    my %values;
    $sth_f->execute($self->ar_id);
    while (my $res = $sth_f->fetchrow_hashref) {
        my $attr = $res->{attribute};
        if (exists($values{$attr})) {
            if (!ref($values{$attr})) {
                if (my $v = $values{$attr}) {
                    $values{$attr} = [ grep { $_ } ($v, $res->{value}) ];
                } else {
                    $values{$attr} = $res->{value};
                }
            } elsif ($res->{value}) {
                push(@{$values{$attr}}, $res->{value});
            }
        } else {
            $values{$attr} = $res->{value};
        }
    }

    %values
}

sub _register_applied {
    my ($self, $comment) = @_;

    my $sth = $self->base->db->prepare(q{
        update request set done=now(), applied = true,
        reason = ? where id = ?
    });
    $sth->execute($comment, $self->ar_id);
}

sub register_discard {
    my ($self, $comment) = @_;

    my $sth = $self->base->db->prepare(q{
        update request set done=now(), applied = false,
        reason = ? where id = ?
    });
    $sth->execute($comment, $self->ar_id);
}

sub _prepare_attrs {
    my ($self, %attrs) = @_;

    my %newvalues = $self->get_values;
    foreach (keys %attrs) {
        $newvalues{$_} = $attrs{$_};
    }
    foreach (keys %newvalues) {
        if (!$self->base->attribute($self->otype, $_)) {
            delete($newvalues{$_});
        }
    }

    return %newvalues;
}

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

    my $sth = $self->accreq->db->prepare(q{
        update request  set automated = false where id = ?
    });
    return $sth->execute($self->ar_id);
}

sub auto_apply_to_object {
    my ($self, $comment) = @_;

    if (!$self->is_for_new_object) {
        if (my $obj = $self->oobject) {
            if ($obj->get_attributes('rev') != $self->objrev) {
                $self->base->log(LA_WARN,
                    'Object %s has been modified, set request as non
                    automated');

                $self->unset_auto;
                return 1; # The automatic action "succeed"
            }
        } else {
            $self->base->log('Cannot apply to non existing object %s',
                $self->object_name);
            return;
        }
    }
    $self->apply_to_object($comment);
}

sub apply_to_object {
    my ($self, $comment, %attrs) = @_;

    my %newvalues = $self->_prepare_attrs(%attrs);

    if ($self->is_for_new_object) {
        if ($self->base->create_object(
            $self->otype,
            $attrs{_name},
            %attrs
        )) {
            $self->_register_applied($comment);
            return 1;
        } else {
            $self->base->log(
                LA_ERR,
                'Error applying DataRequest id=%d to create object %s/%s: %s',
                $self->ar_id,
                $self->otype,
                $attrs{_name},
                $self->base->db->errstr,
            );
            return;
        }
    } else {
        my $obj = $self->oobject or return;

        if (defined($obj->set_c_fields(%newvalues)) &&
            $self->_register_applied($comment)) {
            $self->base->log(
                LA_INFO,
                'DataRequest id=%d applied to object %s/%s',
                $self->ar_id,
                $self->otype,
                $obj->id,
            );
            return 1;
        } else {
            $self->base->log(
                LA_ERR,
                'Error applying DataRequest id=%d to object %s/%s: %s',
                $self->ar_id,
                $self->otype,
                $obj->id,
                $self->base->db->errstr,
            );
            $self->base->rollback;
            return;
        }
    }
}

=head2 FUNCTION TO HANDLE OBJECT

The following functions are provided to use a
C<Datarequest> with the same way a C<LATMOS::Accounts::Base::Object>.

See L<LATMOS::Accounts::Base::Object> documentation.

=cut

=head2 id

=cut

sub id { $_[0]->object_name }

=head2 base

=cut

sub base { $_[0]->accreq->base }

=head2 accreq

=cut

sub accreq { $_[0]->{accreq} }

=head2 type

=cut

sub type { $_[0]->otype }

=head2 get_attributes

=cut

sub get_attributes {
    my ($self, @args) = @_;
    if ($self->ar_id) {
        # TODO not fetching all values each time
        my %values = $self->get_values;
        return $values{$args[0]};
    } elsif (my $obj = $self->oobject) {
        return $obj->get_attributes(@args);
    } else {
        return;
    }
}

=head2 attribute

=cut

sub attribute {
    my ($self, $attrname) = @_;

    my $attr = $self->_attribute($attrname);

    $attr->{_noacl} = 1;

    $attr
}

sub _attribute {
    my ($self, $attrname) = @_;

    if (my $info = $self->attribute_info($attrname)) {
        return $self->base->attribute($self->otype, $info);
    } else {
        my $obj = $self->oobject;
        my $oo =  $obj
            ? $obj->attribute($attrname)
            : $self->base->attribute($self->otype, $attrname);
        return $oo || $self->base->attribute($self->otype, { name => $attrname });
    }
}

1;

__END__

=head1 SEE ALSO

=head1 AUTHOR

Olivier Thauvin, E<lt>olivier.thauvin@latmos.ipsl.frE<gt>

=head1 COPYRIGHT AND LICENSE

Copyright (C) 2008, 2009 CNRS SA/CETP/LATMOS

This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself, either Perl version 5.10.0 or,
at your option, any later version of Perl 5 you may have available.

=cut