source: trunk/LATMOS-Accounts/lib/LATMOS/Accounts/Bases/Mail.pm @ 2136

package LATMOS::Accounts::Bases::Mail;

use 5.010000;
use strict;
use warnings;

use base qw(LATMOS::Accounts::Bases);
use LATMOS::Accounts::Log;
use Fcntl qw(:flock);

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

=head1 NAME

LATMOS::Accounts::Bases::Mail - Base support for mail files

=head1 DESCRIPTION

This base is designed to generated aliases/revaliases files used by postfix or
sendmail. This allow to centralise all information and to automated alias
generation from user real name.

=cut

sub new {
    my ($class, %config) = @_;

    my $base = {
        file => {},
        aliases => {},
        revaliases => {},
    };

    foreach (qw(aliases revaliases)) {
        if ($config{$_}) {
            $base->{file}{$_} = $config{$_};
        } elsif ($config{directory}) {
            $base->{file}{$_} = $config{directory} . '/' . $_;
        } else {
            $base->{file}{$_} = "/etc/$_";
        }
    }


    bless($base, $class);
}

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

    # If aleady loaded just say ok !
    $self->{_loaded} and return 1;

    # warning, comment will be strip !
    if (open(my $handle, '<', $self->{file}{aliases})) {
        $self->log(LA_DEBUG, "Reading file %s", $self->{file}{aliases});
        flock($handle, LOCK_EX);
        while (my $line = <$handle>) {
            chomp($line);
            $line =~ s/^\s*#.*//;
            $line or next;
            my ($name, $forward) = $line =~ /^([^:]+):?\s*(.*)$/;
            $name or do {
                next;
            };
            $forward or next;
            $self->{aliases}{$name} = $forward;
        }
        close($handle);
    } else {
        $self->log(LA_ERR, "Cannot open file '%s` for reading",
            $self->{file}{aliases});
        return;
    }

    if (open(my $handle, '<', $self->{file}{revaliases})) { 
        $self->log(LA_DEBUG, "Reading file %s", $self->{file}{revaliases});
        flock($handle, LOCK_EX);
        while (my $line = <$handle>) {
            chomp($line);
            $line =~ s/^\s*#.*//;
            my ($name, $as) = $line =~ /^(\S+)(?::\s*|\s+)(\S+)$/;
            $name or next;
            $as or do { warn $line; next};
            $self->{revaliases}{$name} = $as;
        }
        close($handle);
    } else {
        $self->log(LA_ERR, "Cannot open file '%s` for reading",
            $self->{file}{revaliases});
        return;
    }

    $self->{_loaded} = 1;

    return 1;
}

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

    if (open(my $handle, '>>', $self->{file}{aliases})) {
        flock($handle, LOCK_EX);
        truncate($handle, 0);
        foreach (sort keys %{ $self->{aliases} }) {
            printf $handle "%s:%s\n", $_, $self->{aliases}{$_};
        }
        close($handle);
        $self->log(LA_INFO, $self->{file}{aliases} . " saved");
    } else {
        $self->log(LA_ERR, "Cannot open file '%s` for writing",
            $self->{file}{aliases});
        return;
    }

    if (open(my $handle, '>', $self->{file}{revaliases})) {
        flock($handle, LOCK_EX);
        truncate($handle, 0);
        foreach (sort keys %{ $self->{revaliases} }) {
            printf $handle "%s %s\n", $_, $self->{revaliases}{$_};
        }
        close($handle);
        $self->log(LA_INFO, $self->{file}{revaliases} . " saved");
    } else {
        $self->log(LA_ERR, "Cannot open file '%s` for writing",
            $self->{file}{revaliases});
        return;
    }

}

sub list_objects {
    my ($self, $type) = @_;

    $type = lc($type);
    lc($type) =~ /^(aliases|revaliases)$/ or return;

    return sort keys %{ $self->{$type} };
}

sub create_object {
    my ($self, $otype, $id, %data) = @_;

    $otype = lc($otype);
    if ($self->{$otype}{$id}) {
        return;
    } elsif ($otype =~ /^aliases$/i) {
        $data{forward} ||= [];
        $self->{$otype}{$id} = ref $data{forward}
            ? join(',', @{$data{forward}})
            : $data{forward};
        return 1;
    } elsif ($data{as} && $otype =~ /^revaliases$/i) {
        $self->{$otype}{$id} = $data{as};
        return 1;
    } else {
        return;
    }
}

sub _delete_object {
    my ($self, $otype, $id) = @_;
    
    $otype = lc($otype);
    $otype =~ /^(aliases|revaliases)$/ or return;
    if ($self->{$otype}{$id}) {
        delete($self->{$otype}{$id});
        return 1;
    } else {
        return;
    }
}

1;

__END__

=head1 SEE ALSO

=head1 AUTHOR

Olivier Thauvin, E<lt>olivier.thauvin@aerov.jussieu.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