selima-perl/lib/perl5/Selima/Logging.pm

# Selima Website Content Management System
# Logging.pm: The loggers.

#  Copyright (c) 2004-2018 imacat.
#
#  Licensed under the Apache License, Version 2.0 (the "License");
#  you may not use this file except in compliance with the License.
#  You may obtain a copy of the License at
#
#      http://www.apache.org/licenses/LICENSE-2.0
#
#  Unless required by applicable law or agreed to in writing, software
#  distributed under the License is distributed on an "AS IS" BASIS,
#  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
#  See the License for the specific language governing permissions and
#  limitations under the License.

# Author: imacat <imacat@mail.imacat.idv.tw>
# First written: 2004-09-26

package Selima::Logging;
use 5.008;
use strict;
use warnings;
use base qw(Exporter);
use vars qw(@EXPORT @EXPORT_OK);
BEGIN {
@EXPORT = qw();
push @EXPORT, qw(log_error log_warn actlog sub check_actlog_file);
push @EXPORT, qw(spamlog check_spamlog_file $ACTLOG $SPAMLOG);
@EXPORT_OK = @EXPORT;
# Prototype declaration
sub log_error($);
sub log_warn($);
sub actlog($;$);
sub check_actlog_file();
sub spamlog($);
sub check_spamlog_file();
}

use Date::Format qw(time2str);
use Encode qw(encode is_utf8 FB_CROAK);
use File::Spec::Functions qw(catfile);

BEGIN {
if (exists $ENV{"MOD_PERL_API_VERSION"} && $ENV{"MOD_PERL_API_VERSION"} >= 2) {
    require Apache2::Connection;
}
}

use Selima::DataVars qw(:env :siteconf :requri);
use Selima::HTTP;
use Selima::LogIn;
use Selima::RemoHost;
use Selima::XFileIO;

use vars qw($ACTLOG $SPAMLOG);

# log_error: Log to Apache error_log as error
sub log_error($) {
    local ($_, %_);
    my $remote;
    $_ = $_[0];
    chomp;
    
    # mod_perl: use Apache->request->log_error
    if ($IS_MODPERL) {
        my $r;
        $r = $IS_MP2? Apache2::RequestUtil->request: Apache->request;
        $remote = defined remote_host? remote_host:
            $r->connection->remote_ip;
        $_ = sprintf "[client %s] %s", $remote, $_;
        $r->log_error($_);
    
    # Non-mod_perl: print to STDERR
    } else {
        $remote = defined remote_host? remote_host:
            $ENV{"REMOTE_ADDR"};
        $_ = sprintf "[client %s] %s", $remote, $_;
        printf STDERR "[%s] [error] %s\n",
            time2str("%a %b %e %T %Y", time), $_;
    }
    return;
}

# log_error: Log to Apache error_log as warning
sub log_warn($) {
    local ($_, %_);
    my $remote;
    $_ = $_[0];
    chomp;
    
    # mod_perl: use Apache->request->log_error
    if ($IS_MODPERL) {
        my $r;
        $r = $IS_MP2? Apache2::RequestUtil->request: Apache->request;
        remote_host;
        $remote = defined remote_host? remote_host:
            $r->connection->remote_ip;
        $_ = sprintf "[client %s] %s", $remote, $_;
        $r->warn($_);
    
    # Non-mod_perl: print to STDERR
    } else {
        $remote = defined remote_host? remote_host:
            $ENV{"REMOTE_ADDR"};
        $_ = sprintf "[client %s] %s", $remote, $_;
        printf STDERR "[%s] [warn] %s\n",
            time2str("%a %b %e %T %Y", time), $_;
    }
    return;
}

# actlog: Log an activity
sub actlog($;$) {
    local ($_, %_);
    my ($msg, $user, $remote);
    ($msg, $user) = @_;
    
    # Set the file location of the activity log file
    check_actlog_file;
    # No valid activity log file is found
    http_500 "Activity log actlog.txt not found"
        if !defined $ACTLOG;
    
    # Escape control characters for safety
    $msg =~ s/\t/\\t/g;
    $msg =~ s/\r/\\r/g;
    $msg =~ s/\n/\\n/g;
    $msg =~ s/([\x00-\x08\x0B\x0C\x0E-\x1F])/sprintf("\\x%02x", ord($1));/ge;
    $msg = encode("UTF-8", $msg, FB_CROAK) if is_utf8($msg);
    
    if (!defined $user) {
        $user = defined get_login_id? get_login_id: "anonymous";
    }
    $remote = $IS_MODPERL? ($IS_MP2?
        Apache2::RequestUtil->request->connection->remote_ip:
        Apache->request->connection->remote_ip):
        $ENV{"REMOTE_ADDR"};
    $msg = sprintf "[%s] %s: (%s from %s) %s\n",
        time2str("%Y-%m-%d %X %z", time), $REQUEST_PATH, $user, $remote, $msg;
    xfappend($ACTLOG, $msg);
    return;
}

# check_actlog_file: Check the activity log file
sub check_actlog_file() {
    local ($_, %_);
    # Gather the candidates
    @_ = qw();
    push @_, catfile("/var/log/apache2", $PACKAGE, "actlog.txt");
    push @_, catfile("/var/log/apache2", "actlog.txt");
    # Found
    foreach (@_) {
        return ($ACTLOG = $_) if -e $_ && -f $_ && -w $_;
    }
    # Not found
    undef $ACTLOG;
    return undef;
}

# spamlog: Log a suspicious spammer
sub spamlog($) {
    local ($_, %_);
    my ($msg, $remote);
    $msg = $_[0];
    
    # Set the file location of the activity log file
    check_spamlog_file;
    # No valid activity log file is found
    http_500 "Spam log spamlog.txt not found"
        if !defined $SPAMLOG;
    
    # Escape control characters for safety
    $msg =~ s/\t/\\t/g;
    $msg =~ s/\r/\\r/g;
    $msg =~ s/\n/\\n/g;
    $msg =~ s/([\x00-\x08\x0B\x0C\x0E-\x1F])/sprintf("\\x%02x", ord($1));/ge;
    $msg = encode("UTF-8", $msg, FB_CROAK) if is_utf8($msg);
    
    $remote = $IS_MODPERL? ($IS_MP2?
        Apache2::RequestUtil->request->connection->remote_ip:
        Apache->request->connection->remote_ip):
        $ENV{"REMOTE_ADDR"};
    $msg = sprintf "[%s] %s: %s: (from %s) %s\n",
        time2str("%Y-%m-%d %X %z", time), $PACKAGE, $REQUEST_PATH, $remote, $msg;
    xfappend($SPAMLOG, $msg);
    return;
}

# check_spamlog_file: Check the spammer log file
sub check_spamlog_file() {
    local ($_, %_);
    # Gather the candidates
    @_ = qw();
    push @_, catfile("/var/log/apache2", $PACKAGE, "spamlog.txt");
    push @_, catfile("/var/log/apache2", "spamlog.txt");
    # Found
    foreach (@_) {
        return ($SPAMLOG = $_) if -e $_ && -f $_ && -w $_;
    }
    # Not found
    undef $SPAMLOG;
    return undef;
}

return 1;