source: trunk/LATMOS-Accounts/lib/LATMOS/Accounts/Bases/Sql/Aliases.pm @ 1821

package LATMOS::Accounts::Bases::Sql::Aliases;

use 5.010000;
use strict;
use warnings;

use base qw(LATMOS::Accounts::Bases::Sql::objects);
use LATMOS::Accounts::Log;
use LATMOS::Accounts::I18N;

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

=head1 NAME

LATMOS::Accounts::Bases::Sql::Aliases - Mail alias object

=cut

sub _object_table { 'aliases' }

sub _key_field { 'name' }

sub _has_extended_attributes { 1 }

sub _get_attr_schema {
    my ($class, $base) = @_;

    
    my $recurs = sub {
        my ($attr) = @_;
        my ($self) = $attr->object;
        my $field = $attr->name; 

        my $sth = $self->db->prepare_cached(q{
            select name from aliases where array[lower($1)] <@
            string_to_array(lower(array_to_string("forward", ',')), ',')
            });
        my @tocheck = ($field =~ /^sameforward$/
            ? $self->get_attributes('forward')
            : ($field =~ /^samedestination$/ 
                ? $self->get_attributes('finalpoint')
                : $self->id));
        my @results;
        my @already;
        while (my $next = shift(@tocheck)) {
            # endless loop detection
            grep { $next eq $_ } @already and do {
                push(@results, $next);
                next;
            };
            push(@already, $next);
            $sth->execute($next);
            while (my $res = $sth->fetchrow_hashref) {
                push(@tocheck, $res->{name});
                $res->{name} eq $self->id and next;
                push(@results, $res->{name});
            }
            $field =~ /^(parents|sameforward)$/ and last; # No recursive search
        }
        return scalar(@results) <= 1 ? $results[0] : \@results;
    };

    $class->SUPER::_get_attr_schema($base,
        {
            name            => {
                ro => 1,
            },
            forward         => {
                label => l('Forward'),
                delayed => 1,
                mandatory => 1,
                multiple => 1,
                monitored => 1,
                set => sub {
                    my ($self, $data) = @_;
                    my $sql = $data
                        ? '{' . join(',', map { $_ =~ s/\\/\\\\/g; '"' .$_.'"' } @$data) . '}'
                        : undef;
                    $base->db->do(
                        q{UPDATE aliases SET forward = }
                        . $base->db->quote($sql) . q{ where name = } .
                        $base->db->quote($self->object->id)
                    );
                    return 1;
                },
                ro => sub {
                    $_[0] && $_[0]->_get_c_field('autoMemberFilter') ? 1 : 0
                },
            },
            rfc822MailMember => {
                iname => 'forward',
                hidden => 1,
                ro => 1,
                multiple => 1,
            },
            finalpoint      => {
                ro => 1,
                multiple => 1,
                get => sub {
                    my ($self) = @_;
                    my $sth = $self->base->db->prepare_cached(q{
                        select forward from aliases where lower(name) = lower(?)
                        limit 1
                        });
                    my @res = ();
                    my @next = @{ $self->object->get_field('forward') || [] };
                    my %seen;
                    while (my $next = shift(@next)) {
                        # Avoiding loop:
                        $seen{$next} and do {
                            push(@res, $next);
                            next;
                        };
                        $seen{$next} = 1;
                        $sth->execute($next);
                        if (my $res = $sth->fetchrow_hashref) {
                            push(@next, @{ $res->{forward} });
                        } else {
                            push(@res, $next);
                        }
                    }
                    $sth->finish;
                    return @res ? \@res : undef;
                },
                label => l('Final recipient')
            },
            parents         => {
                ro => 1,
                get => $recurs,
                label => l('Parents')
            },
            anyparents      => {
                ro => 1,
                get => $recurs,
            },
            sameforward     => {
                ro => 1,
                multiple => 1,
                get => $recurs,
            },
            samedestination => {
                ro => 1,
                multiple => 1,
                get => $recurs,
            },
            user            => {
                ro => 1,
                reference => 'user',
                multiple => 1,
                label => l('User'),
            },
            expire    => {
                inline => 1,
                formtype => 'DATE',
                label => l('Expire'),
            },
            comment => {
                label => l('Comment'),
            },
            autoMemberFilter => {
                multiple => 1,
                set => sub {
                    my ($self, $data) = @_;
                    $self->object->set_fields($self->name, $data) or return;
                    $self->object->populate_dyn_aliases;
                    return 1;
                },
                label => l('Automatics filters'),
            },
            autoFromSutype => {
                multiple => 1,
                set => sub {
                    my ($self, $data) = @_;
                    $self->object->set_fields($self->name, $data) or return;
                    $self->object->populate_dyn_aliases;
                    return 1;
                },
                label => l('From group type'),
            },
            autoExclude => {
                multiple => 1,
                reference => 'user',
                label => l('User excluded'),
            },
        }
    )
}

sub new {
    my ($class, $base, $id) = @_;
    my $sth = $base->db->prepare_cached(q{
        select name from aliases where lower(name) = lower(?)
    });
    $sth->execute($id);
    my $res = $sth->fetchrow_hashref;
    $sth->finish;
    if ($res) {
        $class->SUPER::new($base, $res->{name});
    } else {
        return;
    }
}

sub _create {
    my ($class, $base, $id, %data) = @_;
    $data{'forward'} = [ $data{'forward'} ] unless(ref $data{'forward'});
    @{$data{'forward'}} = grep { $_ } @{$data{'forward'}};
    my $sth = $base->db->prepare_cached(q{
        select name from aliases where lower(name) = lower(?)
        limit 1
        });
    $sth->execute($id);
    my $res = $sth->fetchrow_hashref;
    $sth->finish;
    if ($res) {
        $base->log(LA_ERR, "Aliases %s already exists as %s",
            $id, $res->{name});
        return;
    } else {
        return $class->SUPER::_create($base, $id, %data);
    }
}

sub set_fields {
    my ($self, %data) = @_;

    if ($data{forward}) {
        $data{forward} = ref $data{forward}
            ? $data{forward}
            : [ $data{forward} ];
    }

    $self->SUPER::set_fields(%data);
}

=head2 populate_dyn_aliases

Synchronise aliase's forward according filter set into C<autoMemberFilter> attribute.

=cut

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


    if (!$self->get_field('autoMemberFilter')
     && !$self->get_field('autoFromSutype') ) {
        return 0;
    }

    $self->base->log(LA_DEBUG,
        "Populating aliases %s from autoMemberFilter attribute",
        $self->id
    );

    my $listh = $self->base->db->prepare_cached(q{
        SELECT forward FROM aliases WHERE ikey = ?
    });

    $listh->execute($self->Iid);
    my $res = $listh->fetchrow_hashref;
    $listh->finish;
    my $currentForward = $res->{forward} || [];

    my %email = $self->base->attributes_summary_by_object('user', 'mail');
    my %users;

    my $autoex = $self->get_field('autoExclude');
    my %exclude = map { $_ => 1 } grep { $_  } (ref $autoex ? @$autoex : $autoex);

    if (my $filter = $self->get_field('autoMemberFilter')) {
        $users{$_} = 1 foreach( $self->base->search_objects('user', ref $filter ? @{ $filter } : $filter) );
    }

    if (my $filter = $self->get_field('autoFromSutype')) {
        my @suTypeFilter = map { "sutype=$_" } (ref $filter ? @{ $filter } : $filter);
        foreach my $group ($self->base->search_objects('group', @suTypeFilter)) {
            foreach ($self->base->search_objects('user', "memberOf=$group")) {
                $users{$_} = 1;
            }
        }
    }

    my %forward = ();

    foreach my $user (keys %users) {
        $exclude{$user} and next;
        $email{$user} or next;
        my $mail = $email{$user}->[0] or next;
        $forward{$mail} = 1;
    }

    if (join(',', sort @$currentForward) eq join(',', sort keys %forward)) {
        $self->base->log(
            LA_DEBUG,
            "No need to update alias %s for autoMemberFilter settings",
            $self->id,
        );
        return 0;
    }

    my $sth = $self->base->db->prepare_cached(
        'UPDATE aliases SET forward = ? WHERE ikey = ?'
    );
    if (!$sth->execute([ sort keys %forward ], $self->Iid)) {
        $self->base->log(LA_ERR, "Cannot update forward for aliases %s: %s", $self->id, $sth->errstr());
        return;
    }

    return 1;
}

1;

__END__

=head1 SEE ALSO

L<LATMOS::Accounts::Bases::Sql>

L<LATMOS::Accounts::Bases::Sql::Revaliases>

=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