source: branches/4.0/LATMOS-Accounts/lib/LATMOS/Accounts/Task/Buildlistes.pm @ 1268

package LATMOS::Accounts::Task::Buildlistes;

use strict;
use warnings;
use base qw(LATMOS::Accounts::Task);
use LATMOS::Accounts;
use Config::IniFiles;
use LATMOS::Accounts::Log;
use LATMOS::Accounts::Utils;

=head1 NAME

LATMOS::Accounts::Task::Buildlistes - Task to generate list of mail address
usable by mail robot such as mailman.

=head1 DESCRITPTION

This module is designed to automatically build mailing list members file. The
configuration is handle by F<la-sync-list.ini> file.

=cut

sub needupd {
    my ($self, $lastrev, $currentrev, $syncm) = @_;

    my (undef, $runtime) = $syncm->get_last_rev;
    my $mtime = (stat($self->{_listcfg}->GetFileName))[9] || 0;
    if (!defined($mtime)) {
        la_log LA_DEBUG, "Cannot stat config file: %s: %s",
                $self->{_listcfg}->GetFileName, $!;
        return;
    } elsif (($runtime || 0) <= $mtime) { # To have debug message
        la_log LA_DEBUG, "Config has changed, generating list";
        return 1;
    } elsif ($self->SUPER::needupdate($lastrev, $currentrev, $syncm)) {
        return 1;
    } else {
        return;
    }
}

sub init {
    my ($self) = @_;
    my $LA = LATMOS::Accounts->new($self->{config});
    my $labase = $self->{base} ? $LA->base($self->{base}) : $LA->base;
    $labase && $labase->load or die "Cannot load base";

    my $listconfig = $self->{listconfig} || join('/', $LA->_configdir, 'la-sync-list.ini');
    my $listcfg = Config::IniFiles->new(
        -file => $listconfig,
        -default => '_default_',
    ) or do {
        la_log LA_ERR, "Cannot open list config file $listconfig";
        return;
    };

    $self->{_la} = $LA;
    $self->{_base} = $labase;
    $self->{_listcfg} = $listcfg;

    1;
}

sub run {
    my ($self) = @_;
    my $listcfg = $self->{_listcfg};
    my $labase = $self->{_base};

    my %cache;
    if (my $cmd = $listcfg->val('_default_', 'pre')) {
        exec_command(
            $cmd,
            {
                DIRECTORY => $listcfg->val('_default_', 'destdir'),
                HOOK_TYPE => 'PRE',
            },
        );
    } 

    foreach my $list ($listcfg->Sections) {
        la_log LA_DEBUG, "Start to process %s", $list;
        my %content = ();
        $list eq '_default_' and next;
        $listcfg->val($list, 'ignore') and do {
            la_log LA_DEBUG, "list %s taggued 'ignored'", $list;
            next;
        };
        my $fmt = $listcfg->val($list, 'fmt', '%{mail}');
        my $otype = $listcfg->val($list, 'objects', 'user');
        foreach (grep { $_ } $listcfg->val($list, 'addtolist')) {
            $content{$_} = 1;
        }
        my %ids;
        # finding /^filter/ as search results
        # adding to list results
        foreach my $param ($listcfg->Parameters($list)) {
            $param =~ /^filter/ or next;

            foreach my $id (sort $labase->search_objects(
                    $listcfg->val($list, 'objects', 'user'),
                    $listcfg->val($list, $param),)) {
                $ids{$id} = 1;
            }
        }
        # finding /^excludefilter/ as search results
        # deleting from list results
        my %done;
        foreach my $param ($listcfg->Parameters($list),
                           $listcfg->Parameters('_default_')) {
            $done{$param} and next;
            $done{$param} = 1;
            $param =~ /^excludefilter/ or next;
            $listcfg->val($list, $param) or next;

            foreach my $id (sort $labase->search_objects(
                    $listcfg->val($list, 'objects', 'user'),
                    $listcfg->val($list, $param),)) {
                delete($ids{$id});
            }
        }
        foreach my $id (sort keys %ids) {
            if (!$cache{$otype}{$fmt}{$id}) {
                my $obj = $labase->get_object(
                    $otype,
                    $id,
                );

                $cache{$otype}{$fmt}{$id} = $obj->queryformat($fmt);
            }
            $content{ $cache{$otype}{$fmt}{$id} } = 1;
        }
        # No destdir, no cmd, will do nothing...
        if (my $destdir = $listcfg->val('_default_', 'destdir')) {
            if (open(my $handle, '>', "$destdir/$list")) {
                foreach (sort keys %content) {
                    print $handle $_ ."\n";
                }
                close($handle);
                la_log LA_NOTICE, "%s written", "$destdir/$list";
                if (my $cmd = $listcfg->val('_default_', 'post_file')) {
                    exec_command(
                        $cmd,
                        {
                            DIRECTORY => $destdir,
                            OUTPUT_FILE => $list,
                            HOOK_TYPE => 'POSTFILE',
                        },
                    );
                } 
            } else {
                la_log LA_ERR, "Can't open %s: %s", "$destdir/$list", $!;
            }
        }
        # compat
        if (my $cmd = $listcfg->val($list, 'cmd')) {
            $cmd =~ s/%%/$list/g;
            if (open(my $handle, '|' . $cmd)) {
                foreach (sort keys %content) {
                    print $handle $_ ."\n";
                }
                close($handle);
                if ($?) {
                    la_log(LA_ERR, "Command `%s' exit with status %d", $cmd, $?);
                } else {
                    la_log(LA_NOTICE, "Command `%s' done", $cmd);
                }
            } else {
                la_log LA_ERR, "Can run command `%s': %s", $cmd, $!;
            } 
        }
    }
    if (my $cmd = $listcfg->val('_default_', 'post')) {
        exec_command(
            $cmd,
            {
                DIRECTORY => $listcfg->val('_default_', 'destdir'),
                HOOK_TYPE => 'POST',
            },
        );
    } 

    1;
}

1;

=head1 SEE ALSO

Configuraiton file: L<la-sync-list.ini>

L<LATMOS::Accounts::Task>

=head1 AUTHOR

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

=head1 COPYRIGHT AND LICENSE

Copyright (C) 2008, 2009, 2010, 2011, 2012 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