source: tags/5.2.11/LATMOS-Accounts/lib/LATMOS/Accounts/Log.pm @ 1952

package LATMOS::Accounts::Log;

use strict;
use warnings;
use Sys::Syslog qw(:standard :macros);
use Exporter ();
use Mail::Sendmail;

=head1 NAME

LATMOS::Accounts::Log - Log dispatcher for LATMOS::Accounts

=head1 SYNOPSYS

    use LATMOS::Accounts::Log
    la_log(LA_ERR, "An error has occur");

=head1 DESCRIPTION

This module provide facilities to log to both console, syslog or using callback.

When the environement variable C<LA_DEBUG> is set, all message are print to
C<stderr>.

=cut

our @loglevels = qw(
    LA_EMERG
    LA_ALERT
    LA_CRIT
    LA_ERR
    LA_ERROR
    LA_WARN
    LA_WARNING
    LA_NOTICE
    LA_INFO
    LA_DEBUG
);

use vars qw(@EXPORT_OK @EXPORT %EXPORT_TAGS @ISA);
@ISA = qw(Exporter);
@EXPORT = (qw(
    la_set_log la_log
    ), @loglevels);

@EXPORT_OK = @EXPORT;
%EXPORT_TAGS = (LOGLEVELS => [ @loglevels ]);

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

my %lastmessages = ();

=head1 LOG LEVEL

=over 4

=item LA_EMERG

=cut

sub LA_EMERG { LOG_EMERG } # system is unusable

=item LA_ALERT

=cut

sub LA_ALERT { LOG_ALERT } # action must be taken immediately

=item LA_CRIT

=cut

sub LA_CRIT { LOG_CRIT } # critical conditions

=item LA_ERR, LA_ERROR

=cut

sub LA_ERR   { LOG_ERR } # error conditions
sub LA_ERROR { LA_ERR } # Alias for ERR

=item LA_WARN, LA_WARNING

=cut

sub LA_WARNING { LOG_WARNING } # warning conditions
sub LA_WARN    { LA_WARNING } # warning conditions

=item LA_NOTICE

=cut

sub LA_NOTICE { LOG_NOTICE } # normal, but significant, condition

=item LA_INFO

=cut

sub LA_INFO { LOG_INFO } # informational message

=item LA_DEBUG

=cut

sub LA_DEBUG { LOG_DEBUG } # debug-level message

=back

=cut

my %log_method = (
    syslog => undef,
    console => LA_NOTICE,
    callback => undef,
    mail => undef,
);

my @maillog = ();

=head1 FUNCTIONS

=head2 la_set_log(%options)

Set options to log dispatcher:

=over 4

=item syslog

=item console

=item callback

=back

=cut

sub la_set_log {
    my (%options) = @_;
    while (my ($key, $val) = each(%options)) {
        if ($key eq 'syslog') {
            if ($val) {
                my ($ident, $logopt, $facility) =  @{ ref $val ? $val : [] };
                $ident ||= 'LATMOS::Accounts';
                $logopt ||= 'pid';
                $facility ||= 'LOG_USER';
                openlog($ident, $logopt, $facility);
                $log_method{syslog} = 1;
            }
            next;
        }
        $log_method{$key} = $val;
    }
    1;
}

=head2 lastmessage($level)

Return the last message for C<$level> (LA_ERROR by default)

=cut

sub lastmessage {
    my ($level) = @_;
    return $lastmessages{$level || LA_ERROR};
}

=head2 la_log($level, @sprintf_args)

=cut

sub la_log {
    my ($level, $msg, @args) = @_;
    no warnings 'printf';

    if (!$msg) {
        # Wrong la_log usage
        my @call = caller();
        la_log(LA_WARN, 'empty message at %s:%s', $call[1], $call[2]);
        return;
    }
    if ($level !~ /^\d$/) {
        # Wrong la_log usage
        my @call = caller();
        la_log(LA_WARN, 'unrecognize message level %s at %s:%s', $level, $call[1], $call[2]);
        return;
    }

    $lastmessages{$level} = sprintf($msg, map { defined($_) ? $_ : '' } @args);
    if ($log_method{syslog}) {
        syslog($level, $msg, @args) unless($level >= LA_DEBUG);
    }
    if ($ENV{'LA_DEBUG'}) {
        my @caller = caller;
        my $debug = ($level == LA_DEBUG) ? "$caller[0]:$caller[2] " : '';
        warn sprintf("$debug$msg", @args) . "\n";
    } elsif ($log_method{console} && $level <= $log_method{console}) {
        if ($level >= LA_NOTICE && $level < LA_DEBUG) {
            printf("$msg\n", @args);
        } else {
            my $debug = '';
            if ($level == LA_DEBUG) {
                my @caller = caller;
                $debug = "$caller[0]:$caller[2] ";
            }
            warn sprintf("$debug$msg", map { defined($_) ? $_ : '' } @args) . "\n";
        }
    }
    if ($log_method{callback}) {
        $log_method{callback}->($level, $msg, @args);
    }
    if ($log_method{mail}) {
        # store error to send it later, only ERROR
        push(@maillog, sprintf($msg, @args)) if ($level <= LA_ERROR);
    }
    1;
}

sub _flush_mail {
    @maillog = ();
}

sub _send_mail_log {
    @maillog or return;
    sendmail(
        Subject => "LATMOS::Accounts error from $0",
        To => $log_method{mail},
        From => 'LATMOS-Accounts@latmos.ipsl.fr',
        Message => join("\n", @maillog),
    ) or la_log(LA_ERR, "Cannot sent mail: " . $Mail::Sendmail::error);
    _flush_mail();
}

END {
    _send_mail_log() if($log_method{mail});
}

1;

__END__

=head1 SEE ALSO

=head1 AUTHOR

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

=head1 COPYRIGHT AND LICENSE

Copyright (C) 2009, 2010, 2011, 2012 by Thauvin Olivier

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