Initial checkin.
Signed-off-by: Thomas Hochstein <thh@thh.name>
This commit is contained in:
commit
30132626b8
68 changed files with 5497 additions and 0 deletions
261
MOD/DBIUtils.pm
Normal file
261
MOD/DBIUtils.pm
Normal file
|
|
@ -0,0 +1,261 @@
|
|||
######################################################################
|
||||
#
|
||||
# $Id: DBIUtils.pm 305 2011-12-26 19:51:53Z root $
|
||||
#
|
||||
# Copyright 2007 - 2009 Roman Racine
|
||||
# Copyright 2009 Alexander Bartolich
|
||||
#
|
||||
# This program is free software; you can redistribute it and/or modify
|
||||
# it under the terms of the GNU General Public License as published by
|
||||
# the Free Software Foundation; either version 3 of the License, or
|
||||
# (at your option) any later version.
|
||||
#
|
||||
######################################################################
|
||||
package MOD::DBIUtils;
|
||||
|
||||
use warnings;
|
||||
use strict;
|
||||
use Carp qw( confess );
|
||||
|
||||
use DBI();
|
||||
use MOD::Utils qw(read_private_config);
|
||||
use News::Article();
|
||||
use MOD::DBIUtilsPublic();
|
||||
use Digest::SHA1();
|
||||
|
||||
push @MOD::DBIUtils::ISA,'MOD::DBIUtilsPublic';
|
||||
|
||||
######################################################################
|
||||
sub enter_table($$$$)
|
||||
######################################################################
|
||||
{
|
||||
my ($self,$article,$status,$spamcount) = @_;
|
||||
my %tmphash;
|
||||
for my $headerdata (qw(Reply-To Subject Message-ID)) {
|
||||
$tmphash{$headerdata} = defined($article->header($headerdata)) ? $article->header($headerdata) : ' ';
|
||||
}
|
||||
|
||||
my $table = $self->{'config'}->{'mysql_table'} || confess;
|
||||
my $body = join("\n", $article->body());
|
||||
|
||||
my @columns = (
|
||||
'Sender',
|
||||
'ReplyTo',
|
||||
'Subject',
|
||||
'MessageID',
|
||||
'Spamcount',
|
||||
'Status',
|
||||
'Header',
|
||||
'Body',
|
||||
'Datum',
|
||||
'checksum'
|
||||
);
|
||||
my @values = (
|
||||
$article->header('From'),
|
||||
$tmphash{'Reply-To'},
|
||||
$tmphash{'Subject'},
|
||||
$tmphash{'Message-ID'},
|
||||
$spamcount,
|
||||
$status,
|
||||
join("\n", $article->headers()),
|
||||
$body,
|
||||
);
|
||||
|
||||
my $value_format = '?,?,?,?,?,?,?,?,NOW(),SHA1(Body)';
|
||||
if ($status eq 'moderated')
|
||||
{
|
||||
push @columns, 'Moddatum';
|
||||
$value_format .= ',NOW()';
|
||||
}
|
||||
|
||||
my $rc = $self->{'dbh'}->do(
|
||||
'INSERT IGNORE INTO ' . $table .
|
||||
' (' . join(',', @columns) . ')' .
|
||||
' VALUES(' . $value_format . ')',
|
||||
undef,
|
||||
@values
|
||||
);
|
||||
if ($rc != 1)
|
||||
{
|
||||
my $msg = 'enter_table failed';
|
||||
my $article_id = undef;
|
||||
|
||||
my $age = $self->{'config'}->{'check_duplicates_age'} || 7;
|
||||
my $sha1 = Digest::SHA1::sha1_hex($body);
|
||||
my $stmt = $self->{'dbh'}->prepare(
|
||||
"SELECT id\n" .
|
||||
"\nFROM " . $table .
|
||||
"\nWHERE checksum=?" .
|
||||
"\nAND Datum < DATE_SUB(CURDATE(), INTERVAL ? DAY);"
|
||||
);
|
||||
$stmt->execute($sha1, $age);
|
||||
my $row = $stmt->fetchrow_arrayref;
|
||||
if ($row)
|
||||
{
|
||||
( $article_id ) = @$row;
|
||||
$msg = 'Duplicate received';
|
||||
}
|
||||
|
||||
$msg .= "\n*** sha1_hex(\$body) ***\n" . $sha1;
|
||||
for(my $i = 0; $i <= $#values; $i++)
|
||||
{
|
||||
if ($values[$i])
|
||||
{
|
||||
$msg .= "\n*** " . $columns[$i] . "***\n" . $values[$i];
|
||||
}
|
||||
}
|
||||
$self->increase_errorlevel($article_id, $msg);
|
||||
}
|
||||
return $rc;
|
||||
}
|
||||
|
||||
######################################################################
|
||||
sub select_unposted($)
|
||||
######################################################################
|
||||
{
|
||||
my $self = shift;
|
||||
my $table = $self->{'config'}->{'mysql_table'} || confess;
|
||||
my $query = $self->{'dbh'}->prepare(
|
||||
"SELECT ID, CONCAT(header,\"\\n\\n\",body)\n" .
|
||||
"FROM $table\n" .
|
||||
"WHERE status='moderated'");
|
||||
$query->execute();
|
||||
return $query;
|
||||
}
|
||||
|
||||
######################################################################
|
||||
sub set_posted_status($$$)
|
||||
######################################################################
|
||||
{
|
||||
my ($self,$id,$mid) = @_;
|
||||
my $table = $self->{'config'}->{'mysql_table'} || confess;
|
||||
|
||||
$self->{'dbh'}->do(
|
||||
"UPDATE $table\n" .
|
||||
"SET status='posted', MessageID=(?)\n" .
|
||||
"WHERE ID=(?)\n" .
|
||||
"AND (status = 'moderated' OR status = 'sending')",
|
||||
undef, $mid, $id
|
||||
);
|
||||
$self->{'dbh'}->do(
|
||||
"DELETE FROM ${table}_error\n" .
|
||||
"WHERE article_id=(?)\n",
|
||||
undef, $id
|
||||
);
|
||||
return;
|
||||
}
|
||||
|
||||
######################################################################
|
||||
sub delete_posting($$)
|
||||
######################################################################
|
||||
{
|
||||
my ($self,$id) = @_;
|
||||
my $table = $self->{'config'}->{'mysql_table'} || confess;
|
||||
$self->{'dbh'}->do(
|
||||
"DELETE FROM $table" .
|
||||
"\nWHERE ID=(?)" .
|
||||
"\nAND status <> 'pending'" .
|
||||
"\nAND status <> 'sending'",
|
||||
undef, $id
|
||||
);
|
||||
}
|
||||
|
||||
######################################################################
|
||||
sub select_old_postings($$$$)
|
||||
######################################################################
|
||||
{
|
||||
my ($self,$end,$start,$status) = @_;
|
||||
my $table = $self->{'config'}->{'mysql_table'} || confess;
|
||||
my $query =
|
||||
"SELECT ID, CONCAT(header,\"\\n\\n\",body)" .
|
||||
"\nFROM $table" .
|
||||
"\nWHERE status <> 'pending'" .
|
||||
"\nAND Datum < DATE_SUB(CURDATE(), INTERVAL ? DAY)";
|
||||
my @values = ( $end );
|
||||
if (defined($start)) {
|
||||
$query .= "\nAND Datum > DATE_SUB(CURDATE(), INTERVAL ? DAY)";
|
||||
push @values, $start;
|
||||
}
|
||||
if (defined($status)) {
|
||||
$query .= "\nAND status=?";
|
||||
push @values, $status;
|
||||
}
|
||||
my $stmt = $self->{'dbh'}->prepare($query);
|
||||
$stmt->execute(@values);
|
||||
return $stmt;
|
||||
}
|
||||
|
||||
######################################################################
|
||||
sub delete_old_errors($$$$)
|
||||
######################################################################
|
||||
{
|
||||
my ($self, $end, $start, $status) = @_;
|
||||
my $table = $self->{'config'}->{'mysql_table'} || confess;
|
||||
my $query =
|
||||
"DELETE FROM ${table}_error" .
|
||||
"\nWHERE error_date < DATE_SUB(CURDATE(), INTERVAL ? DAY)";
|
||||
my @values = ( $end );
|
||||
if (defined($start)) {
|
||||
$query .= "\nAND error_date > DATE_SUB(CURDATE(), INTERVAL ? DAY)";
|
||||
push @values, $start;
|
||||
}
|
||||
my $stmt = $self->{'dbh'}->prepare($query);
|
||||
$stmt->execute(@values);
|
||||
return $stmt;
|
||||
}
|
||||
|
||||
######################################################################
|
||||
sub select_pending($)
|
||||
######################################################################
|
||||
{
|
||||
my $self = shift || die;
|
||||
my $table = $self->{'config'}->{'mysql_table'} || confess;
|
||||
my $query =
|
||||
"select DISTINCT(if (length(replyto) > 1,replyto,sender)) AS Adresse" .
|
||||
"\nFROM ${table}" .
|
||||
"\nwhere status='pending'" .
|
||||
"\nAND datum < DATE_SUB(NOW(), INTERVAL ? HOUR)" .
|
||||
"\nAND datum > DATE_SUB(NOW(), INTERVAL ? HOUR)";
|
||||
my $stmt = $self->{'dbh'}->prepare($query);
|
||||
$stmt->execute(
|
||||
$self->{'config'}->{'min_time_until_autoreply'},
|
||||
$self->{'config'}->{'max_time_until_autoreply'}
|
||||
);
|
||||
return $stmt;
|
||||
}
|
||||
|
||||
######################################################################
|
||||
sub increase_errorlevel($$$)
|
||||
######################################################################
|
||||
{
|
||||
my ($self, $article_id, $reason) = @_;
|
||||
|
||||
my $query = sprintf(
|
||||
"INSERT INTO %s_error\n" .
|
||||
"(article_id, error_date, error_count, error_message)\n" .
|
||||
"VALUES (?, NOW(), 1, ?)\n" .
|
||||
"ON DUPLICATE KEY UPDATE\n" .
|
||||
" error_count = IF(error_count + 1 > 100, 100, error_count + 1),\n" .
|
||||
" error_date = NOW(),\n" .
|
||||
" error_message=(?)",
|
||||
$self->{'config'}->{'mysql_table'}
|
||||
);
|
||||
my $stmt = $self->{'dbh'}->prepare($query);
|
||||
$stmt->execute($article_id, $reason, $reason);
|
||||
return;
|
||||
}
|
||||
|
||||
######################################################################
|
||||
sub check_subject($$)
|
||||
######################################################################
|
||||
{
|
||||
my ($self,$subject) = @_;
|
||||
my $query = $self->{'dbh'}->prepare("select count(subject) from $self->{'config'}->{'mysql_table'} where subject=(?) and status='spam';");
|
||||
$query->execute($subject);
|
||||
my ($result) = @{$query->fetchrow_arrayref};
|
||||
return $result;
|
||||
}
|
||||
|
||||
######################################################################
|
||||
1;
|
||||
######################################################################
|
||||
478
MOD/DBIUtilsPublic.pm
Normal file
478
MOD/DBIUtilsPublic.pm
Normal file
|
|
@ -0,0 +1,478 @@
|
|||
######################################################################
|
||||
#
|
||||
# $Id: DBIUtilsPublic.pm 267 2010-05-27 19:46:57Z alba $
|
||||
#
|
||||
# Copyright 2007 - 2009 Roman Racine
|
||||
# Copyright 2009 Alexander Bartolich
|
||||
#
|
||||
# This program is free software; you can redistribute it and/or modify
|
||||
# it under the terms of the GNU General Public License as published by
|
||||
# the Free Software Foundation; either version 3 of the License, or
|
||||
# (at your option) any later version.
|
||||
#
|
||||
######################################################################
|
||||
package MOD::DBIUtilsPublic;
|
||||
|
||||
use warnings;
|
||||
use strict;
|
||||
use DBI;
|
||||
use News::Article;
|
||||
use Carp qw(confess);
|
||||
use Time::Local;
|
||||
|
||||
sub display_single;
|
||||
sub set_status;
|
||||
sub set_status_by_moderator;
|
||||
sub displayrange;
|
||||
sub get_working_by_id;
|
||||
sub get_reason;
|
||||
sub set_rejected;
|
||||
sub get_statistics;
|
||||
|
||||
# 'spam' can be put back to 'pending' queue
|
||||
# 'moderated' tells poster.pl to send the message via NNTP (there is
|
||||
# no safe way to undo this)
|
||||
# 'rejected' means that a mail was sent the poster - cannot be undone
|
||||
# 'deleted' can be put back to 'pending' queue
|
||||
# 'posted' means that message was sent to server - cannot be undone
|
||||
|
||||
use constant NOT_FINAL =>
|
||||
"status <> 'rejected' AND status <> 'posted' AND status <> 'sending'";
|
||||
|
||||
######################################################################
|
||||
# Constructor, open a new connection to the database
|
||||
######################################################################
|
||||
sub new($$)
|
||||
######################################################################
|
||||
{
|
||||
my ($class,$configref) = @_;
|
||||
my $self = {};
|
||||
$self->{'config'} = $configref;
|
||||
$self->{'dsn'} = "DBI:mysql:database=$self->{'config'}->{'mysql_db'};host=$self->{'config'}->{'mysql_host'};port=$self->{'config'}->{'mysql_port'}";
|
||||
$self->{'dbh'} = DBI->connect($self->{'dsn'},$self->{'config'}->{'mysql_username'},$self->{'config'}->{'mysql_password'},
|
||||
{ RaiseError => 1})
|
||||
or die($DBI::errstr);
|
||||
|
||||
bless $self,$class;
|
||||
return $self;
|
||||
}
|
||||
|
||||
|
||||
##Die nachfolgenden Methoden sind fuer den Gebrauch im Webinterface bestimmt, alle Methoden, die den Zustand der DB
|
||||
##aendern, muessen idempotent sein!
|
||||
|
||||
######################################################################
|
||||
# Update the Status of a posting
|
||||
######################################################################
|
||||
sub set_status($$$$)
|
||||
######################################################################
|
||||
{
|
||||
my ($self, $id, $newstatus, $prevstatus) = @_;
|
||||
my $table = $self->{'config'}->{'mysql_table'} || confess;
|
||||
|
||||
my $query =
|
||||
"UPDATE $table" .
|
||||
"\nSET status=(?)" .
|
||||
"\nWHERE id=(?)";
|
||||
if ($prevstatus)
|
||||
{
|
||||
$query .= "\nAND (\n status = '";
|
||||
$query .= join("'\n OR status = '", @$prevstatus);
|
||||
$query .= "'\n)";
|
||||
}
|
||||
else
|
||||
{
|
||||
$query .= "\nAND " . NOT_FINAL;
|
||||
}
|
||||
|
||||
my $stmt = $self->{'dbh'}->prepare($query);
|
||||
return $stmt->execute($newstatus, $id);
|
||||
}
|
||||
|
||||
######################################################################
|
||||
# Update the Status of a posting
|
||||
######################################################################
|
||||
sub set_status_by_moderator()
|
||||
######################################################################
|
||||
{
|
||||
my ($self, $newstatus, $id, $moderator) = @_;
|
||||
my $table = $self->{'config'}->{'mysql_table'} || confess;
|
||||
|
||||
$self->{'dbh'}->do(
|
||||
"UPDATE $table" .
|
||||
"\nSET status=(?), Moderator=(?), Moddatum=NOW()" .
|
||||
"\nWHERE id=(?)" .
|
||||
"\nAND " . NOT_FINAL,
|
||||
undef, $newstatus, $moderator, $id
|
||||
);
|
||||
}
|
||||
|
||||
######################################################################
|
||||
sub set_rejected($$$$$)
|
||||
######################################################################
|
||||
{
|
||||
my ($self, $newstatus, $article_id, $moderator, $reply) = @_;
|
||||
my $table = $self->{'config'}->{'mysql_table'} || confess;
|
||||
|
||||
$self->set_status_by_moderator($newstatus, $article_id, $moderator);
|
||||
|
||||
my $query = sprintf(
|
||||
"INSERT INTO %s_reply\n" .
|
||||
"(article_id, reply_date, reply_message)\n" .
|
||||
"VALUES (?, NOW(), ?)\n" .
|
||||
"ON DUPLICATE KEY UPDATE\n" .
|
||||
" reply_date = NOW(),\n" .
|
||||
" reply_message=(?)",
|
||||
$table
|
||||
);
|
||||
my $stmt = $self->{'dbh'}->prepare($query);
|
||||
$stmt->execute($article_id, $reply, $reply);
|
||||
}
|
||||
|
||||
######################################################################
|
||||
sub set_reply($$$)
|
||||
######################################################################
|
||||
{
|
||||
my ($self, $article_id, $reply) = @_;
|
||||
my $table = $self->{'config'}->{'mysql_table'} || confess;
|
||||
|
||||
my $query = sprintf(
|
||||
"INSERT INTO %s_reply\n" .
|
||||
"(article_id, reply_date, reply_message)\n" .
|
||||
"VALUES (?, NOW(), ?)\n" .
|
||||
"ON DUPLICATE KEY UPDATE\n" .
|
||||
" reply_date = NOW(),\n" .
|
||||
" reply_message=(?)",
|
||||
$table
|
||||
);
|
||||
my $stmt = $self->{'dbh'}->prepare($query);
|
||||
$stmt->execute($article_id, $reply, $reply);
|
||||
}
|
||||
|
||||
######################################################################
|
||||
# Display a range out of a table
|
||||
######################################################################
|
||||
sub displayrange($$$$$)
|
||||
######################################################################
|
||||
{
|
||||
my ($self,$status,$start,$number_of_results,$overviewref) = @_;
|
||||
$start = 0 if ($start !~ /^\d+$/);
|
||||
$number_of_results = 1 if ($number_of_results !~ /^\d+$/);
|
||||
|
||||
my $table = $self->{'config'}->{'mysql_table'}
|
||||
|| confess 'No "mysql_table" in config';
|
||||
|
||||
my $query = sprintf(
|
||||
"SELECT %s" .
|
||||
"\nFROM %s" .
|
||||
"\nWHERE status=(?)" .
|
||||
"\nORDER BY ID DESC" .
|
||||
"\nLIMIT %d,%d",
|
||||
join(',', @$overviewref),
|
||||
$table,
|
||||
$start, $number_of_results
|
||||
);
|
||||
|
||||
my $stmt = $self->{'dbh'}->prepare($query);
|
||||
$stmt->execute($status);
|
||||
return $stmt;
|
||||
}
|
||||
|
||||
######################################################################
|
||||
# display a single entry of a table
|
||||
######################################################################
|
||||
sub display_single($$$)
|
||||
######################################################################
|
||||
{
|
||||
my ($self,$status,$id) = @_;
|
||||
|
||||
my $table = $self->{'config'}->{'mysql_table'} || confess;
|
||||
|
||||
my $query =
|
||||
"SELECT CONCAT(header, \"\\n\\n\", body)," .
|
||||
"\n Status," .
|
||||
"\n Spamcount," .
|
||||
"\n Moderator," .
|
||||
"\n Moddatum AS 'Decision Date'," .
|
||||
"\n Flag" .
|
||||
"\nFROM $table" .
|
||||
"\nWHERE id=(?)";
|
||||
my @param = ( $id );
|
||||
|
||||
if ($status)
|
||||
{
|
||||
$query .= "\nAND Status=(?)";
|
||||
push @param, $status;
|
||||
}
|
||||
|
||||
my $stmt = $self->{'dbh'}->prepare($query);
|
||||
$stmt->execute(@param);
|
||||
return $stmt;
|
||||
}
|
||||
|
||||
######################################################################
|
||||
sub set_status_posted($$$)
|
||||
######################################################################
|
||||
{
|
||||
my ($self,$id,$user) = @_;
|
||||
return $self->set_status_by_moderator('moderated', $id, $user);
|
||||
}
|
||||
|
||||
######################################################################
|
||||
sub get_working_by_id($$)
|
||||
######################################################################
|
||||
{
|
||||
my ($self,$id) = @_;
|
||||
my $table = $self->{'config'}->{'mysql_table'} || confess;
|
||||
my $query = $self->{'dbh'}->prepare(
|
||||
"SELECT" .
|
||||
"\n CONCAT(header,\"\\n\\n\",body) AS Posting," .
|
||||
"\n if (length(replyto) > 1,replyto,sender) AS Adresse" .
|
||||
"\nFROM $table" .
|
||||
"\nWHERE ID=(?)" .
|
||||
"\nAND " . NOT_FINAL
|
||||
);
|
||||
$query->execute($id);
|
||||
return $query;
|
||||
}
|
||||
|
||||
######################################################################
|
||||
sub get_reason($$)
|
||||
######################################################################
|
||||
{
|
||||
my ($self,$id) = @_;
|
||||
my $table = $self->{'config'}->{'mysql_table'} || confess;
|
||||
|
||||
my $query = $self->{'dbh'}->prepare(
|
||||
"SELECT reply_message" .
|
||||
"\nFROM ${table}, ${table}_reply" .
|
||||
"\nWHERE ${table}.id = ${table}_reply.article_id" .
|
||||
"\nAND article_id=(?)" .
|
||||
"\nAND (status='rejected' OR status='deleted')
|
||||
");
|
||||
$query->execute($id);
|
||||
return $query;
|
||||
}
|
||||
|
||||
######################################################################
|
||||
sub display_errors($$$$$)
|
||||
######################################################################
|
||||
{
|
||||
my ($self,$status,$start,$number_of_results,$overviewref) = @_;
|
||||
$start = 0 if ($start !~ /^\d+$/);
|
||||
$number_of_results = 1 if ($number_of_results !~ /^\d+$/);
|
||||
|
||||
my $table = $self->{'config'}->{'mysql_table'} || confess;
|
||||
|
||||
my $query = sprintf(
|
||||
"SELECT %s" .
|
||||
"\nFROM %s_error_view" .
|
||||
"\nORDER BY error_date DESC" .
|
||||
"\nLIMIT %d, %d",
|
||||
join(',', @$overviewref),
|
||||
$table,
|
||||
$start, $number_of_results
|
||||
);
|
||||
my $stmt = $self->{'dbh'}->prepare($query);
|
||||
$stmt->execute();
|
||||
return $stmt;
|
||||
}
|
||||
|
||||
######################################################################
|
||||
sub get_errormessage($$)
|
||||
######################################################################
|
||||
{
|
||||
my ($self,$id) = @_;
|
||||
|
||||
my $table = $self->{'config'}->{'mysql_table'} || confess;
|
||||
|
||||
my $query = sprintf(
|
||||
"SELECT error_message" .
|
||||
"\nFROM %s_error" .
|
||||
"\nWHERE error_id=(?)",
|
||||
$table
|
||||
);
|
||||
my $stmt = $self->{'dbh'}->prepare($query);
|
||||
$stmt->execute($id);
|
||||
return $stmt;
|
||||
}
|
||||
|
||||
######################################################################
|
||||
sub invert_flag($$)
|
||||
######################################################################
|
||||
{
|
||||
my ($self,$id) = @_;
|
||||
my $table = $self->{'config'}->{'mysql_table'} || confess;
|
||||
$self->{'dbh'}->do(
|
||||
"UPDATE $table" .
|
||||
"\nSET flag = !flag" .
|
||||
"\nWHERE ID=(?)" .
|
||||
"\nAND " . NOT_FINAL,
|
||||
undef, $id
|
||||
);
|
||||
}
|
||||
|
||||
######################################################################
|
||||
sub calc_item_stats($$)
|
||||
######################################################################
|
||||
{
|
||||
my ($r_result, $r_items) = @_;
|
||||
|
||||
my @items = sort { $a <=> $b }( @$r_items );
|
||||
return undef unless($#items >= 0);
|
||||
|
||||
my $sum = 0;
|
||||
for my $i( @items ) { $sum += $i; }
|
||||
|
||||
my $nr_items = 1 + $#items;
|
||||
my $pivot = int($nr_items / 2);
|
||||
my $median = $items[$pivot];
|
||||
if (($nr_items % 2) == 0)
|
||||
{
|
||||
$median = ( $median + $items[$pivot - 1] ) / 2;
|
||||
}
|
||||
|
||||
$r_result->{'count'} = $nr_items;
|
||||
$r_result->{'sum'} = $sum;
|
||||
$r_result->{'avg'} = $sum / $nr_items;
|
||||
$r_result->{'median'} = $median;
|
||||
$r_result->{'min'} = $items[0];
|
||||
$r_result->{'max'} = $items[ $#items ];
|
||||
|
||||
return $r_items;
|
||||
}
|
||||
|
||||
######################################################################
|
||||
sub get_reaction_time($;$$$)
|
||||
######################################################################
|
||||
{
|
||||
my ( $self, $from, $to, $status ) = @_;
|
||||
|
||||
# Warning: Plain "Moddatum - Datum" returns strange values when
|
||||
# crossing day boundaries. Using unix_timestamp instead.
|
||||
|
||||
my $query =
|
||||
"select unix_timestamp(Datum), timestampdiff(SECOND, Datum, Moddatum)" .
|
||||
"\nfrom " . $self->{'config'}->{'mysql_table'} .
|
||||
"\nwhere datum is not null" .
|
||||
"\nand Moddatum is not null" .
|
||||
"\nand Datum is not null";
|
||||
|
||||
if ($from)
|
||||
{ $query .= "\nand datum >= from_unixtime($from)"; }
|
||||
if ($to)
|
||||
{ $query .= "\nand datum < from_unixtime($to)"; }
|
||||
if ($status)
|
||||
{ $query .= "\nand Status = '$status'"; }
|
||||
|
||||
my $sth = $self->{'dbh'}->prepare($query);
|
||||
$sth->execute();
|
||||
|
||||
my %result;
|
||||
while(my $row = $sth->fetchrow_arrayref )
|
||||
{
|
||||
my $datum = 0 + $row->[0];
|
||||
my $reaction_time = 0 + $row->[1];
|
||||
my ($sec, $minute, $hour, $mday, $month, $year, $wday, $yday, $isdst) =
|
||||
localtime($datum);
|
||||
|
||||
my $y = sprintf("%04d", $year + 1900);
|
||||
my $m = sprintf("%02d", $month + 1);
|
||||
my $d = sprintf("%02d", $mday);
|
||||
|
||||
my $items = $result{$y}->{$m}->{$d}->{'items'};
|
||||
if (defined( $items ))
|
||||
{
|
||||
push @$items, $reaction_time;
|
||||
}
|
||||
else
|
||||
{
|
||||
$result{$y}->{$m}->{$d}->{'items'} = [ $reaction_time ];
|
||||
}
|
||||
}
|
||||
|
||||
# we are going to modify the hash so we need robust iteration
|
||||
my @year = keys(%result);
|
||||
my @all_items;
|
||||
|
||||
for my $year(@year)
|
||||
{
|
||||
my $r_month = $result{$year};
|
||||
my @month = keys(%$r_month);
|
||||
my @year_items;
|
||||
|
||||
for my $month(@month)
|
||||
{
|
||||
my $r_mday = $r_month->{$month};
|
||||
my @mday = keys(%$r_mday);
|
||||
my @month_items;
|
||||
|
||||
for my $mday(@mday)
|
||||
{
|
||||
my $r = $r_mday->{$mday};
|
||||
my $r_items = $r->{'items'};
|
||||
push @month_items, @$r_items;
|
||||
calc_item_stats($r, $r_items);
|
||||
# delete $r->{'items'};
|
||||
}
|
||||
|
||||
push @year_items, @month_items;
|
||||
calc_item_stats($r_mday->{'total'} = {}, \@month_items);
|
||||
}
|
||||
push @all_items, @year_items;
|
||||
calc_item_stats($r_month->{'total'} = {}, \@year_items);
|
||||
}
|
||||
calc_item_stats($result{'total'} = {}, \@all_items);
|
||||
|
||||
return \%result;
|
||||
}
|
||||
|
||||
######################################################################
|
||||
sub get_statistics($)
|
||||
######################################################################
|
||||
{
|
||||
my ($self) = @_;
|
||||
my $dbh = $self->{'dbh'}
|
||||
|| confess 'No "dbh" in self';
|
||||
my $table = $self->{'config'}->{'mysql_table'} || confess;
|
||||
|
||||
#
|
||||
# Warning: The combination of union and selectall_arrayref does not
|
||||
# like null values. They are just ommitted from the result.
|
||||
#
|
||||
my $arrayref = $dbh->selectall_arrayref(
|
||||
"select unix_timestamp(min(datum)) from $table" .
|
||||
"\nunion" .
|
||||
"\nselect unix_timestamp(max(datum)) from $table"
|
||||
);
|
||||
|
||||
if (!$arrayref) { return undef; }
|
||||
if (!$arrayref->[1]) { return undef; }
|
||||
if (!$arrayref->[0]) { return undef; }
|
||||
|
||||
# add 1 because query is (datum >= min and datum < max)
|
||||
my $to = 1 + $arrayref->[1]->[0];
|
||||
my $from = $arrayref->[0]->[0];
|
||||
undef $arrayref;
|
||||
|
||||
my $result = {
|
||||
'all' => $self->get_reaction_time($from, $to)
|
||||
};
|
||||
for my $status(
|
||||
'pending',
|
||||
'moderated',
|
||||
'spam',
|
||||
'rejected',
|
||||
'deleted',
|
||||
'posted',
|
||||
'sending')
|
||||
{
|
||||
$result->{$status} = $self->get_reaction_time($from, $to, $status);
|
||||
}
|
||||
|
||||
return $result;
|
||||
}
|
||||
|
||||
######################################################################
|
||||
1;
|
||||
######################################################################
|
||||
811
MOD/Displaylib.pm
Normal file
811
MOD/Displaylib.pm
Normal file
|
|
@ -0,0 +1,811 @@
|
|||
######################################################################
|
||||
#
|
||||
# $Id: Displaylib.pm 305 2011-12-26 19:51:53Z root $
|
||||
#
|
||||
# Copyright 2007-2009 Roman Racine
|
||||
# Copyright 2009-2011 Alexander Bartolich
|
||||
#
|
||||
# This program is free software; you can redistribute it and/or modify
|
||||
# it under the terms of the GNU General Public License as published by
|
||||
# the Free Software Foundation; either version 3 of the License, or
|
||||
# (at your option) any later version.
|
||||
#
|
||||
######################################################################
|
||||
package MOD::Displaylib;
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
use Carp qw( confess );
|
||||
|
||||
use Mail::Mailer();
|
||||
use News::Article();
|
||||
use News::Article::Response();
|
||||
use MIME::QuotedPrint();
|
||||
use MIME::Base64();
|
||||
use Encode();
|
||||
use CGI();
|
||||
use CGI::Pretty();
|
||||
|
||||
use MOD::DBIUtilsPublic;
|
||||
use MOD::Utils;
|
||||
|
||||
use constant VERSION => 0.09;
|
||||
|
||||
use constant MENU_MESSAGES => [
|
||||
[ 'pending', 'Pending' ],
|
||||
[ 'spam', 'Spam' ],
|
||||
[ 'moderated', 'Approved' ],
|
||||
[ 'posted', 'Posted' ],
|
||||
[ 'rejected', 'Rejected' ],
|
||||
[ 'deleted', 'Deleted' ],
|
||||
[ 'errors', 'Error Messages' ],
|
||||
];
|
||||
use constant MENU_CONFIGURATION => undef;
|
||||
|
||||
use constant MENU_MAIN => [
|
||||
[ 'pending', 'Messages', MENU_MESSAGES ],
|
||||
[ 'config', 'Configuration', MENU_CONFIGURATION ],
|
||||
];
|
||||
|
||||
######################################################################
|
||||
sub new($$$)
|
||||
######################################################################
|
||||
{
|
||||
my ($class, $configref, $privileged) = @_;
|
||||
my $self = {};
|
||||
|
||||
$self->{'db'} = MOD::DBIUtilsPublic->new($configref);
|
||||
my $q = $self->{'q'} = CGI->new();
|
||||
|
||||
my $self_url = $q->self_url;
|
||||
$self_url =~ s/\?+.+$//;
|
||||
$self->{'self_url'} = $self_url;
|
||||
|
||||
$self->{'config'} = $configref;
|
||||
$self->{'privileged'} = $privileged;
|
||||
|
||||
my $lang = MOD::Utils::get_translator_language(
|
||||
$configref->{'html_language'},
|
||||
$configref->{'http_negotiate_language'}
|
||||
);
|
||||
$self->{'trans_lang'} = $lang;
|
||||
$self->{'trans'} = MOD::Utils::get_translator($lang);
|
||||
|
||||
if ($privileged)
|
||||
{
|
||||
my $authentication = $configref->{'http_authentication_method'};
|
||||
die "No 'http_authentication_method' in configuration file." unless($authentication);
|
||||
|
||||
if ($q->auth_type() && $q->auth_type() eq $authentication)
|
||||
{
|
||||
$self->{'user_name'} = $q->remote_user();
|
||||
}
|
||||
elsif ($authentication eq 'None')
|
||||
{
|
||||
$self->{'user_name'} = $q->remote_host();
|
||||
}
|
||||
die 'Not authorized' unless($self->{'user_name'});
|
||||
}
|
||||
|
||||
bless $self, $class;
|
||||
return $self;
|
||||
}
|
||||
|
||||
######################################################################
|
||||
sub display_start($;$$$@)
|
||||
######################################################################
|
||||
{
|
||||
my $self = shift;
|
||||
my %args = @_;
|
||||
|
||||
my $trans = $self->{'trans'} || confess 'No translator';
|
||||
my $title = $args{'-title'} || confess 'No -title';
|
||||
$title = $trans->($title);
|
||||
|
||||
my $group = $self->{'config'}->{'moderated_group'};
|
||||
my @title;
|
||||
push @title, '[*]' if ( $args{'-mark'} );
|
||||
push @title, $group if ($group);
|
||||
push @title, $title if ($title);
|
||||
|
||||
my $q = $self->{'q'};
|
||||
my @head = ($q->meta({
|
||||
-http_equiv => 'expires',
|
||||
-content => '0'
|
||||
}));
|
||||
|
||||
my $refresh = $args{'-refresh'};
|
||||
if ($refresh)
|
||||
{
|
||||
push @head, $q->meta({
|
||||
-http_equiv => 'Refresh',
|
||||
-content => $refresh
|
||||
});
|
||||
}
|
||||
|
||||
my @param = (
|
||||
-title => join(' ', @title),
|
||||
-head => \@head
|
||||
);
|
||||
|
||||
my $css = $self->{'config'}->{'html_stylesheet_href'};
|
||||
if ($css)
|
||||
{ push @param, -style => { -src => $css }; }
|
||||
|
||||
print
|
||||
$q->header,
|
||||
$q->start_html( @param );
|
||||
$self->print_menu_items() if ($self->{'privileged'});
|
||||
|
||||
print '<div class="huhuContents">';
|
||||
print $q->h1($title);
|
||||
my $subtitle = $args{'-subtitle'};
|
||||
if ($subtitle)
|
||||
{
|
||||
printf '<div class="huhuSubtitle">%s</div>', $trans->($subtitle);
|
||||
}
|
||||
}
|
||||
|
||||
######################################################################
|
||||
sub display_end($)
|
||||
######################################################################
|
||||
{
|
||||
my ($self) = @_;
|
||||
|
||||
my $group = $self->{'config'}->{'moderated_group'};
|
||||
my $user = $self->{'user_name'};
|
||||
|
||||
my @a;
|
||||
push @a, $group if ($group);
|
||||
push @a, $self->{'trans_lang'};
|
||||
push @a, $user if ($user);
|
||||
push @a, 'huhu version ' . VERSION;
|
||||
|
||||
print
|
||||
'<div class="huhuVersion">',
|
||||
join(' · ', @a),
|
||||
'.</div>',
|
||||
'</div><!-- class="huhuContents" -->',
|
||||
$self->{'q'}->end_html;
|
||||
}
|
||||
|
||||
######################################################################
|
||||
sub display_die_msg($$$)
|
||||
######################################################################
|
||||
{
|
||||
my ($self, $title, $msg) = @_;
|
||||
my $trans = $self->{'trans'} || confess 'No translator';
|
||||
|
||||
$self->display_start(-title => 'Error');
|
||||
print '<div class="huhuError">',
|
||||
$trans->($msg ? $msg : $title),
|
||||
'</div>';
|
||||
$self->display_end();
|
||||
}
|
||||
|
||||
######################################################################
|
||||
sub display_table($@)
|
||||
######################################################################
|
||||
{
|
||||
my $self = shift || confess 'No $self';
|
||||
my %args = @_;
|
||||
|
||||
my $status = $args{'-status'} || confess 'No -status';
|
||||
my $start = $args{'-start'}; # can be 0
|
||||
my $no_of_elements = $args{'-no_of_elements'} || confess 'No -no_of_elements';
|
||||
my $overviewref = $args{'-overviewref'} || confess 'No -overviewref';
|
||||
my $decisionref = $args{'-decisionref'} || confess 'No -decisionref';
|
||||
my $cmd = $args{'-cmd'};
|
||||
|
||||
my @hidden_columns = ( 'flag', 'id' );
|
||||
{
|
||||
my $extra_hidden_columns = $args{'-hiddencolumns'};
|
||||
if ($extra_hidden_columns) {
|
||||
push @hidden_columns, @$extra_hidden_columns;
|
||||
}
|
||||
}
|
||||
my @columns = ( @hidden_columns, @$overviewref );
|
||||
|
||||
my $db = $self->{'db'} || confess 'No "db" in $self';
|
||||
|
||||
my $dataref;
|
||||
if ($status eq 'errors' and $self->{'privileged'}) {
|
||||
$dataref = $db->display_errors($status,$start,$no_of_elements,\@columns);
|
||||
} else {
|
||||
$dataref = $db->displayrange($status,$start,$no_of_elements,\@columns);
|
||||
}
|
||||
|
||||
my $trans = $self->{'trans'} || confess 'No translator';
|
||||
my $sqlnames = $dataref->{'NAME'} || confess 'No "NAME" in $dataref';
|
||||
my @names = map { CGI::escapeHTML($trans->( $_ )) } (
|
||||
@$sqlnames[1 + $#hidden_columns .. $#$sqlnames],
|
||||
'Available Actions'
|
||||
);
|
||||
|
||||
my $ref = $dataref->fetchrow_arrayref();
|
||||
my $q = $self->{'q'} || confess 'No "q" in $self';
|
||||
|
||||
$self->display_start(
|
||||
-title => $args{'-title'},
|
||||
-subtitle => $args{'-subtitle'},
|
||||
-mark => $ref && $self->{'privileged'},
|
||||
-refresh => '300; ' . $q->url() . '?' . $cmd
|
||||
);
|
||||
|
||||
print '<table class="huhuPostList">';
|
||||
print $q->Tr($q->th({-align=>'left'},\@names));
|
||||
|
||||
my $css = $self->{'config'}->{'html_stylesheet_href'};
|
||||
my $flagattr = ($css) ? ' class="huhuFlag"' : ' bgcolor="#ffcccc"';
|
||||
|
||||
my $row_nr = 0;
|
||||
if ($ref) {
|
||||
do {
|
||||
$row_nr++;
|
||||
my @dataline = @{$ref};
|
||||
my $flag = $dataline[0];
|
||||
my $rowattr = ($flag and $self->{'privileged'})
|
||||
? $flagattr
|
||||
: ($row_nr % 2)
|
||||
? ' class="huhuOdd"'
|
||||
: ' class="huhuEven"';
|
||||
|
||||
my $id = $dataline[1];
|
||||
print "<tr$rowattr>";
|
||||
for my $i(1 + $#hidden_columns .. $#dataline) {
|
||||
my $data = $dataline[$i];
|
||||
$data = CGI::escapeHTML(substr($self->decode_line($data),0,40));
|
||||
$data =~ s/\@/#/g if (!defined($self->{'user_name'}));
|
||||
print $q->td($data);
|
||||
}
|
||||
print'<td>';
|
||||
$self->display_decisionbuttons($decisionref, $ref, \@hidden_columns);
|
||||
print '</td></tr>',"\n";
|
||||
} while ($ref = $dataref->fetchrow_arrayref);
|
||||
}
|
||||
|
||||
if ($row_nr == 0)
|
||||
{
|
||||
printf '<tr><td class="huhuNoRows" colspan="%d">', 1 + $#names;
|
||||
print $trans->('No matching records available.');
|
||||
print '</td></tr>';
|
||||
}
|
||||
|
||||
print "</table>\n";
|
||||
$self->nextpage($cmd, $start, $args{'-display_per_page'});
|
||||
|
||||
$self->display_end();
|
||||
return;
|
||||
}
|
||||
|
||||
sub display_reason {
|
||||
my ($self,$id,$decisionref,$title) = @_;
|
||||
my $dataref = $self->{'db'}->get_reason($id);
|
||||
my $reason;
|
||||
eval {
|
||||
($reason) = @{$dataref->fetchrow_arrayref};
|
||||
}; if ($@) {
|
||||
$self->display_die_msg('No reason stored in database!');
|
||||
return;
|
||||
}
|
||||
|
||||
$self->display_start(-title => $title);
|
||||
|
||||
print
|
||||
'<div class="huhuReason">',
|
||||
'<pre width="100">', CGI::escapeHTML($reason), '</pre>',
|
||||
'</div>';
|
||||
$self->display_decisionbuttons($decisionref, [ $id ]);
|
||||
print $self->{'q'}->end_html;
|
||||
return;
|
||||
}
|
||||
|
||||
sub display_navigation_back() {
|
||||
my ($self) = @_;
|
||||
my $q = $self->{'q'} || confess 'No q';
|
||||
my $trans = $self->{'trans'} || confess 'No translator';
|
||||
print
|
||||
'<div class="huhuNavigation">',
|
||||
'<span>',
|
||||
$q->a({ href => $q->referer() }, $trans->('Back')),
|
||||
'</span>',
|
||||
'</div>';
|
||||
}
|
||||
|
||||
sub display_article_info($$$)
|
||||
{
|
||||
my ( $self, $sqlnames, $row ) = @_;
|
||||
|
||||
$sqlnames || confess 'No "NAME" in $dataref';
|
||||
$row || confess 'No $row';
|
||||
$#$row == $#$sqlnames || confess '$#$row != $#$sqlnames';
|
||||
|
||||
my @a;
|
||||
for(my $i = 1; $i <= $#$row; $i++)
|
||||
{
|
||||
my $value = $row->[$i];
|
||||
if ($value)
|
||||
{
|
||||
push @a,
|
||||
CGI::escapeHTML($sqlnames->[$i]) .
|
||||
': ' .
|
||||
CGI::escapeHTML($value);
|
||||
}
|
||||
}
|
||||
if (@a)
|
||||
{
|
||||
print
|
||||
'<div class="huhuArticleInfo">',
|
||||
join(' · ', @a),
|
||||
'</div>';
|
||||
}
|
||||
}
|
||||
|
||||
######################################################################
|
||||
sub display_article($@)
|
||||
######################################################################
|
||||
{
|
||||
my $self = shift || confess 'No $self';
|
||||
my %args = @_;
|
||||
|
||||
my $status = $args{'-status'};
|
||||
my $id = $args{'-id'};
|
||||
my $headerref = $args{'-headerref'};
|
||||
my $decisionref = $args{'-decisionref'};
|
||||
my $fullheader = $args{'-fullheader'};
|
||||
|
||||
if ($status eq 'errors') {
|
||||
$status = undef;
|
||||
}
|
||||
|
||||
my $dataref = $self->{'db'}->display_single($status,$id);
|
||||
my $row = $dataref->fetchrow_arrayref;
|
||||
if (!$row || $#$row < 1) {
|
||||
$self->display_die_msg('_ALREADY_HANDLED' . " (status=$status, id=$id)");
|
||||
return;
|
||||
}
|
||||
|
||||
my $article = $self->decode_article(News::Article->new(\$row->[0]));
|
||||
|
||||
$self->display_start(-title => 'Selected Article');
|
||||
$self->display_article_info($dataref->{'NAME'}, $row);
|
||||
my $q = $self->{'q'} || confess 'No "q" in $self';
|
||||
|
||||
print '<table class="huhuArticle">';
|
||||
if ($fullheader) {
|
||||
my $header = join "\n",$article->headers();
|
||||
print $q->Tr($q->td({-colspan=>2},'<pre width="100">' . CGI::escapeHTML($header) .'</pre>'));
|
||||
} else {
|
||||
for my $headerline (@{$headerref}) {
|
||||
print
|
||||
'<tr class="huhuArticleHeader">',
|
||||
'<th>', CGI::escapeHTML($headerline), '</th>',
|
||||
'<td>', CGI::escapeHTML($article->header($headerline)), '</td>',
|
||||
'</tr>';
|
||||
}
|
||||
}
|
||||
my @ngs = split ',', $article->header('Newsgroups');
|
||||
if ($self->{'user_name'} && @ngs > 2)
|
||||
{
|
||||
my $trans = $self->{'trans'} || confess 'No translator';
|
||||
print $q->Tr($q->td(
|
||||
{-colspan=>2,-bgcolor=>'#ffcccc'},
|
||||
$trans->( '_CROSSPOSTED' )
|
||||
));
|
||||
}
|
||||
|
||||
print $q->Tr($q->td({-colspan=>2},
|
||||
'<pre width="100">' . CGI::escapeHTML(join ("\n",$article->body())) . '</pre>')),
|
||||
'</table><table class="huhuDecisionButtons"><tr><td>';
|
||||
$self->display_decisionbuttons($decisionref, [ $id ]);
|
||||
print "</td></tr>\n</table>";
|
||||
|
||||
$self->display_navigation_back();
|
||||
print $q->end_html;
|
||||
return;
|
||||
}
|
||||
|
||||
######################################################################
|
||||
sub display_errormessage($$$)
|
||||
######################################################################
|
||||
{
|
||||
my ($self, $id, $title) = @_;
|
||||
my $dataref = $self->{'db'}->get_errormessage($id);
|
||||
my $input;
|
||||
eval {
|
||||
($input) = @{$dataref->fetchrow_arrayref};
|
||||
}; if ($@) {
|
||||
$self->display_die_msg('_ERROR_GONE');
|
||||
return;
|
||||
}
|
||||
|
||||
$self->display_start(-title => $title);
|
||||
my $q = $self->{'q'};
|
||||
|
||||
print '<div class="huhuErrorMessage"><pre>',
|
||||
CGI::escapeHTML($input),
|
||||
'</pre></div>';
|
||||
$self->display_navigation_back();
|
||||
print $q->end_html;
|
||||
return;
|
||||
}
|
||||
|
||||
######################################################################
|
||||
sub generate_answer($$$$)
|
||||
######################################################################
|
||||
{
|
||||
my ($self, $id, $behaviour, $title) = @_;
|
||||
my $db = $self->{'db'} || confess 'No "db" in $self';
|
||||
my $trans = $self->{'trans'} || confess 'No translator';
|
||||
my $q = $self->{'q'} || confess 'No q';
|
||||
|
||||
# first of all move the article out of the pending queue
|
||||
$db->set_status_by_moderator('deleted', $id, $self->{'user_name'});
|
||||
|
||||
my $dataref = $db->get_working_by_id($id);
|
||||
my ($input,$addr);
|
||||
eval {
|
||||
($input,$addr) = @{$dataref->fetchrow_arrayref};
|
||||
}; if ($@) {
|
||||
$self->display_die_msg('_ALREADY_HANDLED');
|
||||
return;
|
||||
}
|
||||
my $article = $self->decode_article(News::Article->new(\$input));
|
||||
|
||||
my $attribution = sprintf(
|
||||
$trans->('%s wrote:'),
|
||||
$article->header('From')
|
||||
);
|
||||
|
||||
my $response = News::Article->response(
|
||||
$article,
|
||||
{
|
||||
'From' => $self->{'config'}->{'mailfrom'},
|
||||
},
|
||||
'respstring' => sub { return $attribution; }
|
||||
);
|
||||
|
||||
my $body = join ("\n",$response->body());
|
||||
$self->display_start(-title => $title);
|
||||
|
||||
if ($behaviour eq 'answer')
|
||||
{
|
||||
print
|
||||
$q->start_form,
|
||||
$q->hidden(-name => 'id', -value => $id),
|
||||
$q->table
|
||||
(
|
||||
$q->Tr([
|
||||
$q->td(['From', $self->{'config'}->{'mailfrom'}]),
|
||||
$q->td(['To', CGI::escapeHTML($addr)]),
|
||||
$q->td(['Subject', CGI::escapeHTML($response->header('Subject'))]),
|
||||
$q->td(
|
||||
{ -colspan => 2},
|
||||
$q->textarea({
|
||||
-name =>'antwort',
|
||||
-cols => 80,
|
||||
-rows => 40,
|
||||
-default => $body,
|
||||
-wrap => 'hard'
|
||||
})
|
||||
),
|
||||
$q->td(
|
||||
{ -colspan => 2 },
|
||||
$q->submit(
|
||||
-name => 'action.Send Mail',
|
||||
-value => $trans->('Send Mail')
|
||||
),
|
||||
$q->submit(
|
||||
-name => 'action.Put back in queue',
|
||||
-value => $trans->('Put back in queue')
|
||||
)
|
||||
)
|
||||
])
|
||||
),
|
||||
$q->end_form;
|
||||
}
|
||||
else
|
||||
{
|
||||
print
|
||||
$trans->('_EXPLAIN_REASON'),
|
||||
$q->start_form,
|
||||
$q->hidden({ -name => 'id', -value => $id }),
|
||||
$q->textarea({
|
||||
-name => 'antwort',
|
||||
-cols => 80,
|
||||
-rows => 40,
|
||||
-default => $body,
|
||||
-wrap => 'hard'
|
||||
}),
|
||||
'<br/>',
|
||||
$q->submit(
|
||||
-name => 'action.Delete and save reason',
|
||||
-value => $trans->('Delete and save reason')
|
||||
),
|
||||
$q->submit(
|
||||
-name => 'action.Put back in queue',
|
||||
-value => $trans->('Put back in queue')
|
||||
),
|
||||
$q->end_form;
|
||||
}
|
||||
print $q->end_html;
|
||||
return;
|
||||
}
|
||||
|
||||
######################################################################
|
||||
sub delete_posting
|
||||
######################################################################
|
||||
{
|
||||
my ($self,$id) = @_;
|
||||
my $antwort = $self->{'q'}->param('antwort');
|
||||
$antwort =~ s/\>/>/sg;
|
||||
$antwort =~ s/\</</sg;
|
||||
$antwort =~ s/\&/&/sg;
|
||||
$self->{'db'}->set_rejected('deleted', $id, $self->{'user_name'}, $antwort);
|
||||
return;
|
||||
}
|
||||
|
||||
######################################################################
|
||||
sub send_mail($$)
|
||||
######################################################################
|
||||
{
|
||||
my ($self,$id) = @_;
|
||||
my $antwort = $self->{'q'}->param('antwort');
|
||||
$antwort =~ s/\>/>/sg;
|
||||
$antwort =~ s/\</</sg;
|
||||
$antwort =~ s/\&/&/sg;
|
||||
|
||||
my $trans = $self->{'trans'} || confess 'No translator';
|
||||
|
||||
my $dataref = $self->{'db'}->get_working_by_id($id);
|
||||
my ($input,$addr);
|
||||
eval {
|
||||
($input,$addr) = @{$dataref->fetchrow_arrayref};
|
||||
}; if ($@) {
|
||||
$self->display_die_msg('_ALREADY_HANDLED');
|
||||
return 0;
|
||||
}
|
||||
|
||||
my $article = News::Article->new(\$input);
|
||||
my $original_subject = $article->header('Subject');
|
||||
if (!$original_subject)
|
||||
{ $original_subject = $trans->('No subject'); }
|
||||
|
||||
$article = $self->decode_article($article);
|
||||
if ($addr =~ /(,|\n)/s or $addr =~ /invalid>$/) {
|
||||
$self->display_die_msg('_ERROR_INVALID_ADDRESS');
|
||||
return 0;
|
||||
}
|
||||
my $mailer = new Mail::Mailer;
|
||||
|
||||
my $subject_prefix = $trans->('Your post regarding');
|
||||
$original_subject =~ s/(AW|Re):\s*$subject_prefix\s*/Re:/i;
|
||||
|
||||
$mailer->open({
|
||||
'From' => $self->{'config'}->{'mailfrom'},
|
||||
'Subject' => $subject_prefix . ' ' . $original_subject,
|
||||
'To' => $addr,
|
||||
'Content-Type' => "text/plain;\n charset=\"". $self->{'config'}->{'html_content_type'}. '"',
|
||||
'Content-Transfer-Encoding' => '8bit'
|
||||
});
|
||||
print $mailer $antwort;
|
||||
$mailer->close();
|
||||
$self->{'db'}->set_rejected('rejected', $id, $self->{'user_name'}, $antwort);
|
||||
return 1;
|
||||
}
|
||||
|
||||
######################################################################
|
||||
sub display_decisionbuttons
|
||||
######################################################################
|
||||
{
|
||||
my ($self, $decisionref, $hidden_values, $hidden_names) = @_;
|
||||
|
||||
$hidden_names = [ 'id' ] unless($hidden_names);
|
||||
|
||||
my $q = $self->{'q'} || confess 'No "q" in $self';
|
||||
my $trans = $self->{'trans'} || confess 'No translator';
|
||||
|
||||
print $q->start_form;
|
||||
for(my $i = 0; $i <= $#$hidden_names; $i++)
|
||||
{
|
||||
printf
|
||||
'<input type="hidden" name="%s" value="%s"/>',
|
||||
$hidden_names->[$i], $hidden_values->[$i];
|
||||
}
|
||||
for my $decision (@{$decisionref})
|
||||
{
|
||||
print $q->submit(
|
||||
-name => 'action.' . $decision,
|
||||
-label => CGI::escapeHTML($trans->($decision))
|
||||
);
|
||||
}
|
||||
print $q->end_form;
|
||||
return;
|
||||
}
|
||||
|
||||
|
||||
sub nextpage {
|
||||
my ($self, $cmd, $start, $display_per_page) = @_;
|
||||
|
||||
my $q = $self->{'q'} || confess 'No "q" in $self';
|
||||
$cmd || confess 'No $cmd';
|
||||
my $trans = $self->{'trans'} || confess 'No translator';
|
||||
|
||||
if (!defined($display_per_page) || $display_per_page !~ /^\d+$/)
|
||||
{
|
||||
$display_per_page = $self->{'config'}->{'display_per_page'};
|
||||
}
|
||||
$start = 0 if ($start !~ /^\d+$/);
|
||||
|
||||
my $before = $start - $display_per_page;
|
||||
my $next = $start + $display_per_page;
|
||||
$before = 0 if ($before < 0);
|
||||
my $self_url = $self->{'self_url'} || confess;
|
||||
|
||||
print '<div class="huhuNavigation"><span>',
|
||||
$q->a(
|
||||
{ href => $self_url . '?'. $cmd . ',' . $before },
|
||||
$trans->('Previous page')
|
||||
),
|
||||
'</span><span>',
|
||||
$q->a(
|
||||
{ href => $self_url . '?'. $cmd . ',' . $next },
|
||||
$trans->('Next page')
|
||||
),
|
||||
'</span></div>';
|
||||
return;
|
||||
}
|
||||
|
||||
######################################################################
|
||||
sub print_menu_items($$$)
|
||||
######################################################################
|
||||
{
|
||||
my $self = shift || confess;
|
||||
my $r_items = shift || MENU_MAIN;
|
||||
my $level = shift || 0;
|
||||
|
||||
my $self_url = $self->{'self_url'} || confess;
|
||||
my $trans = $self->{'trans'} || confess 'No translator';
|
||||
|
||||
printf '<ul class="huhuMainMenu%d">', $level;
|
||||
for my $r_definition(@$r_items)
|
||||
{
|
||||
my $submenu = $r_definition->[2];
|
||||
printf
|
||||
'<li><span><a href="%s">%s</a></span>',
|
||||
$self_url . '?' . $r_definition->[0],
|
||||
$trans->( $r_definition->[1] );
|
||||
if ($submenu)
|
||||
{
|
||||
$self->print_menu_items($submenu, $level + 1);
|
||||
}
|
||||
print '</li>';
|
||||
}
|
||||
print '</ul>';
|
||||
}
|
||||
|
||||
sub set_status_by_moderator {
|
||||
my ($self, $newstatus, $id) = @_;
|
||||
$self->{'db'}->set_status_by_moderator($newstatus, $id, $self->{'user_name'});
|
||||
return;
|
||||
}
|
||||
|
||||
sub post {
|
||||
my ($self,$id) = @_;
|
||||
$self->{'db'}->set_status_posted($id, $self->{'user_name'});
|
||||
return;
|
||||
}
|
||||
|
||||
sub decode_article {
|
||||
my ($self, $article) = @_;
|
||||
|
||||
$self || confess 'No $self';
|
||||
$article || confess 'No $article';
|
||||
|
||||
for my $headerline (qw(Subject From Reply-To)) {
|
||||
$article->set_headers($headerline,$self->decode_line($article->header($headerline)));
|
||||
}
|
||||
|
||||
my $body = join "\n",$article->body();
|
||||
|
||||
if (defined($article->header('Content-Transfer-Encoding')) and
|
||||
$article->header('Content-Transfer-Encoding') eq 'quoted-printable') {
|
||||
$body = MIME::QuotedPrint::decode($body);
|
||||
}
|
||||
my $encoding;
|
||||
if (defined($article->header('Content-Type')) and
|
||||
$article->header('Content-Type') =~ m|^text/plain;.+charset=[\s"]*([\w-]+)[\s"]?|si) {
|
||||
$encoding = $1;
|
||||
} else {
|
||||
$encoding = 'iso-8859-1';
|
||||
}
|
||||
eval {
|
||||
if (Encode::find_encoding($encoding)->perlio_ok) {
|
||||
Encode::from_to($body,$encoding,$self->{'config'}->{'html_content_type'});
|
||||
}
|
||||
};
|
||||
$article->set_body(($body));
|
||||
return $article;
|
||||
}
|
||||
|
||||
sub decode_line {
|
||||
my ($self,$line) = @_;
|
||||
if (!$self->{'privileged'}) {
|
||||
$line =~ s/\@/#/g;
|
||||
}
|
||||
my $newline;
|
||||
while ($line =~ s/^(.*?)=\?([^?]+)\?(.)\?([^?]*)\?=(?:\r?\n +)?//s) {
|
||||
my ($before,$charset,$encoding,$content) = ($1,$2,lc($3),$4);
|
||||
$newline .= $before;
|
||||
if ($encoding eq 'q') {
|
||||
$content =~ s/_/ /g;
|
||||
$content = MIME::QuotedPrint::decode($content);
|
||||
chomp $content;
|
||||
} elsif ($encoding eq 'b') {
|
||||
$content = MIME::Base64::decode($content);
|
||||
}
|
||||
eval {
|
||||
if (Encode::find_encoding($charset)->perlio_ok) {
|
||||
Encode::from_to($content,$charset,$self->{'config'}->{'html_content_type'});
|
||||
}
|
||||
};
|
||||
$newline .= $content;
|
||||
}
|
||||
$newline .= $line;
|
||||
return $newline;
|
||||
}
|
||||
|
||||
sub set_flag {
|
||||
my ($self,$id) = @_;
|
||||
$self->{'db'}->invert_flag($id);
|
||||
return;
|
||||
}
|
||||
|
||||
use constant SHOW_CONFIG => (
|
||||
'approve_string',
|
||||
'check_duplicates_age',
|
||||
'display_per_page',
|
||||
'followup_to',
|
||||
'html_content_type',
|
||||
'http_authentication_method',
|
||||
'http_negotiate_language',
|
||||
'mailfrom',
|
||||
'moderated_group',
|
||||
'mysql_host',
|
||||
'mysql_port',
|
||||
'mysql_username',
|
||||
);
|
||||
|
||||
######################################################################
|
||||
sub display_config($)
|
||||
######################################################################
|
||||
{
|
||||
my $self = shift || confess;
|
||||
|
||||
my $q = $self->{'q'} || confess 'No "q" in $self';
|
||||
my $trans = $self->{'trans'} || confess 'No "trans" in $self';
|
||||
my $config = $self->{'config'} || confess 'No "config" in $self';
|
||||
|
||||
$self->display_start(
|
||||
-title => $trans->('Configuration'),
|
||||
# -subtitle => $args{'-subtitle'},
|
||||
-mark => 0,
|
||||
# -refresh => '300; ' . $q->url() . '?' . $cmd
|
||||
);
|
||||
|
||||
print '<table class="huhuPostList">';
|
||||
print $q->Tr($q->th({-align=>'left'}, [ 'Key', 'Value' ]));
|
||||
|
||||
my @key = SHOW_CONFIG;
|
||||
for my $key(@key)
|
||||
{
|
||||
printf "<tr><td>%s</td><td>%s</td></tr>", $key, $config->{$key};
|
||||
}
|
||||
print "</table>";
|
||||
|
||||
$self->display_end();
|
||||
}
|
||||
|
||||
######################################################################
|
||||
1;
|
||||
######################################################################
|
||||
281
MOD/Handler.pm
Normal file
281
MOD/Handler.pm
Normal file
|
|
@ -0,0 +1,281 @@
|
|||
######################################################################
|
||||
#
|
||||
# $Id: Handler.pm 261 2010-02-21 16:10:09Z root $
|
||||
#
|
||||
# Copyright 2007-2009 Roman Racine
|
||||
# Copyright 2009-2010 Alexander Bartolich
|
||||
#
|
||||
# This program is free software; you can redistribute it and/or modify
|
||||
# it under the terms of the GNU General Public License as published by
|
||||
# the Free Software Foundation; either version 3 of the License, or
|
||||
# (at your option) any later version.
|
||||
#
|
||||
######################################################################
|
||||
package MOD::Handler;
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
use Carp qw( confess );
|
||||
use CGI();
|
||||
use MOD::Utils;
|
||||
use MOD::Displaylib;
|
||||
|
||||
######################################################################
|
||||
sub new($$)
|
||||
######################################################################
|
||||
{
|
||||
my ($class, $filename) = @_;
|
||||
my $self = {};
|
||||
|
||||
my %config = MOD::Utils::read_public_config($filename);
|
||||
$self->{'config'} = \%config;
|
||||
|
||||
$self->{'d'} = MOD::Displaylib->new(\%config, 1);
|
||||
$self->{'q'} = $self->{'d'}->{'q'} || confess;
|
||||
|
||||
bless $self, $class;
|
||||
return $self;
|
||||
}
|
||||
|
||||
######################################################################
|
||||
sub run($)
|
||||
######################################################################
|
||||
{
|
||||
my $self = shift || confess;
|
||||
|
||||
my $query = $ENV{'QUERY_STRING'};
|
||||
$query =~ s/keywords=//;
|
||||
my ($cmd, $start, $id) = split(',',$query);
|
||||
if (!defined($start) || $start !~ /^\d+$/) {
|
||||
$start = 0;
|
||||
}
|
||||
if (!$cmd) { $cmd = 'pending'; }
|
||||
|
||||
my $q = $self->{'q'} || confess 'No "q" in $self';
|
||||
|
||||
$id = $q->param('id');
|
||||
if (!defined($id) || $id !~ /^\d+$/) {
|
||||
$id = 0;
|
||||
}
|
||||
|
||||
if ($q->param('action.Show') ||
|
||||
$q->param('action.Header') ||
|
||||
$q->param('action.Brief Headers') ||
|
||||
$q->param('action.Show Post'))
|
||||
{
|
||||
return $self->display_single($cmd, $start, $id);
|
||||
}
|
||||
if (
|
||||
$q->param('action.Spam') ||
|
||||
$q->param('action.No Spam') ||
|
||||
$q->param('action.Put back in queue'))
|
||||
{
|
||||
$self->{'d'}->set_status_by_moderator(
|
||||
$q->param('action.Spam') ? 'spam' : 'pending',
|
||||
$id
|
||||
);
|
||||
return $self->display_overview($cmd, $start, $id);
|
||||
}
|
||||
if ($q->param('action.Flag')) {
|
||||
$self->{'d'}->set_flag($id);
|
||||
return $self->display_overview($cmd, $start, $id);
|
||||
}
|
||||
if ($q->param('action.Reject')) {
|
||||
return $self->reject('answer', $id);
|
||||
}
|
||||
if ($q->param('action.Approve')) {
|
||||
$self->{'d'}->post($id);
|
||||
return $self->display_overview($cmd, $start, $id);
|
||||
}
|
||||
if ($q->param('action.Send Mail')) {
|
||||
$self->{'d'}->send_mail($id) &&
|
||||
return $self->display_overview($cmd, $start, $id);
|
||||
}
|
||||
if ($q->param('action.Show Reply') ||
|
||||
$q->param('action.Reason'))
|
||||
{
|
||||
return $self->display_answer($cmd, $start, $id);
|
||||
}
|
||||
if ($q->param('action.Delete')) {
|
||||
return $self->reject('noanswer', $id);
|
||||
}
|
||||
if ($q->param('action.Delete and save reason')) {
|
||||
$self->{'d'}->delete_posting($id);
|
||||
return $self->display_overview($cmd, $start, $id);
|
||||
}
|
||||
if ($q->param('action.Show Error Message')) {
|
||||
return $self->display_errormessage($q->param('error_id'));
|
||||
}
|
||||
if ($cmd eq 'config') {
|
||||
return $self->{'d'}->display_config();
|
||||
}
|
||||
|
||||
return $self->display_overview($cmd, $start, $id);
|
||||
}
|
||||
|
||||
use constant SQL_TIME_FORMAT => '"%d.%m.%Y, %H:%i:%s"';
|
||||
use constant DEFAULT_COLUMNS => [
|
||||
'Moderator',
|
||||
'Sender',
|
||||
'Subject',
|
||||
'Date_Format(Datum, ' . SQL_TIME_FORMAT . ") AS 'Incoming Date'",
|
||||
'Date_Format(Moddatum, ' . SQL_TIME_FORMAT . ") AS 'Decision Date'"
|
||||
];
|
||||
use constant PENDING_COLUMNS => [
|
||||
'Sender',
|
||||
'Subject',
|
||||
'DATE_Format(Datum, ' . SQL_TIME_FORMAT . ') Date',
|
||||
'Spamcount'
|
||||
];
|
||||
use constant OVERVIEW => {
|
||||
'spam' => {
|
||||
-decisionref => [ 'Show', 'No Spam', 'Flag' ],
|
||||
-overviewref => [
|
||||
'Moderator',
|
||||
'Sender',
|
||||
'Subject',
|
||||
'DATE_Format(Datum, ' . SQL_TIME_FORMAT . ') Date',
|
||||
'Spamcount'
|
||||
],
|
||||
-title => 'Spam Folder',
|
||||
-subtitle => '_SUBTITLE_SPAM',
|
||||
},
|
||||
'pending' => {
|
||||
-decisionref => [ 'Show', 'Spam', 'Flag' ],
|
||||
-overviewref => PENDING_COLUMNS,
|
||||
-title => 'Pending Posts',
|
||||
-subtitle => '_SUBTITLE_PENDING',
|
||||
},
|
||||
'rejected' => {
|
||||
-title => 'Rejected Posts',
|
||||
-subtitle => '_SUBTITLE_REJECTED',
|
||||
},
|
||||
'errors' => {
|
||||
-decisionref => [ 'Show Post', 'Show Error Message' ],
|
||||
-overviewref => [
|
||||
'error_date',
|
||||
'article_sender',
|
||||
'article_subject',
|
||||
'article_status',
|
||||
'error_count',
|
||||
'LEFT(error_message, INSTR(error_message, "\n")) AS error_message',
|
||||
],
|
||||
-title => 'Error Messages',
|
||||
-subtitle => '_SUBTITLE_ERROR',
|
||||
-hiddencolumns => [ 'error_id' ],
|
||||
},
|
||||
'moderated' => {
|
||||
-title => 'Approved Messages',
|
||||
-subtitle => '_SUBTITLE_APPROVED',
|
||||
},
|
||||
'posted' => {
|
||||
-title => 'Posted Messages',
|
||||
-subtitle => '_SUBTITLE_POSTED',
|
||||
},
|
||||
'deleted' => {
|
||||
-title => 'Deleted Posts',
|
||||
-subtitle => '_SUBTITLE_DELETED',
|
||||
},
|
||||
};
|
||||
|
||||
|
||||
sub display_overview {
|
||||
my ($self, $cmd, $start, $id) = @_;
|
||||
my @decisions;
|
||||
my @overviewdata;
|
||||
my ($status, $title);
|
||||
|
||||
my $ovref = OVERVIEW->{$cmd} || confess 'Illegal $cmd';
|
||||
my %params = %{$ovref}; # create copy of the hash
|
||||
|
||||
if (!exists( $params{'-cmd'} )) {
|
||||
$params{'-cmd'} = $cmd;
|
||||
}
|
||||
if (!exists( $params{'-status'} )) {
|
||||
$params{'-status'} = $cmd;
|
||||
}
|
||||
if (!exists( $params{'-decisionref'} )) {
|
||||
$params{'-decisionref'} = [ 'Show' ];
|
||||
}
|
||||
if (!exists( $params{'-overviewref'} )) {
|
||||
$params{'-overviewref'} = DEFAULT_COLUMNS;
|
||||
}
|
||||
if (!exists( $params{'-no_of_elements'} )) {
|
||||
my $config = $self->{'config'} || confess 'No "config" in $self';
|
||||
my $c = $config->{'display_per_page'} || confess 'No "display_per_page" in $config';
|
||||
$params{'-no_of_elements'} = $c;
|
||||
}
|
||||
|
||||
$params{'-start'} = $start;
|
||||
$params{'-startrange'} = $id;
|
||||
|
||||
$self->{'d'}->display_table(%params);
|
||||
}
|
||||
|
||||
sub reject {
|
||||
my ($self,$behaviour,$id) = @_;
|
||||
my $title = ($behaviour eq 'noanswer')
|
||||
? 'Delete Post'
|
||||
: 'Reject Post';
|
||||
$self->{'d'}->generate_answer($id,$behaviour,$title);
|
||||
return;
|
||||
}
|
||||
|
||||
sub display_answer {
|
||||
my ($self,$cmd,$start,$id) = @_;
|
||||
my $title = ($cmd eq 'rejected') ? 'Reply' : 'Reason';
|
||||
my @decisions = ('Show Post');
|
||||
$self->{'d'}->display_reason($id,\@decisions,$title);
|
||||
return;
|
||||
}
|
||||
|
||||
sub display_errormessage {
|
||||
my ($self,$id) = @_;
|
||||
$self->{'d'}->display_errormessage($id, 'Error Message');
|
||||
return;
|
||||
}
|
||||
|
||||
use constant HEADERS => [
|
||||
'From',
|
||||
'Reply-To',
|
||||
'Subject',
|
||||
'Message-ID',
|
||||
'Date',
|
||||
'Newsgroups',
|
||||
'Followup-To',
|
||||
];
|
||||
|
||||
use constant SINGLE => {
|
||||
'pending' => [ 'Approve', 'Reject', 'Flag', 'Spam', 'Delete' ],
|
||||
'spam' => [ 'No Spam', 'Approve', 'Flag', 'Reject', 'Delete' ],
|
||||
'errors' => [ 'Reject', 'Flag', 'Spam', 'Delete' ],
|
||||
'moderated' => [ 'Put back in queue' ],
|
||||
'posted' => [],
|
||||
'rejected' => [ 'Show Reply' ],
|
||||
'deleted' => [ 'Put back in queue', 'Reason' ],
|
||||
};
|
||||
|
||||
sub display_single {
|
||||
my ($self, $cmd, $start, $id) = @_;
|
||||
|
||||
my $q = $self->{'q'} || confess 'No "q" in $self';
|
||||
my $decisionref = SINGLE->{$cmd} || confess "Illegal \$cmd ($cmd)";
|
||||
my @decisions = @$decisionref;
|
||||
|
||||
my $fullheader = $q->param('action.Header') ? 1 : 0;
|
||||
push(@decisions, $fullheader ? 'Brief Headers' : 'Header');
|
||||
|
||||
my %args = (
|
||||
-status => $cmd,
|
||||
-id => $id,
|
||||
-headerref => HEADERS,
|
||||
-decisionref => \@decisions,
|
||||
-fullheader => $fullheader
|
||||
);
|
||||
$self->{'d'}->display_article(%args);
|
||||
return;
|
||||
}
|
||||
|
||||
######################################################################
|
||||
1;
|
||||
######################################################################
|
||||
85
MOD/NotificationSocket.pm
Normal file
85
MOD/NotificationSocket.pm
Normal file
|
|
@ -0,0 +1,85 @@
|
|||
#!/usr/bin/perl -sw
|
||||
######################################################################
|
||||
#
|
||||
# $Id: NotificationSocket.pm 266 2010-05-18 15:14:08Z alba $
|
||||
#
|
||||
# Copyright 2010 Alexander Bartolich
|
||||
#
|
||||
# This program is free software; you can redistribute it and/or modify
|
||||
# it under the terms of the GNU General Public License as published by
|
||||
# the Free Software Foundation; either version 3 of the License, or
|
||||
# (at your option) any later version.
|
||||
#
|
||||
######################################################################
|
||||
package MOD::NotificationSocket;
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
use Carp qw( confess );
|
||||
|
||||
use Socket qw(
|
||||
PF_UNIX
|
||||
sockaddr_un
|
||||
SOCK_STREAM
|
||||
SOMAXCONN
|
||||
);
|
||||
|
||||
######################################################################
|
||||
sub socket_read($;$$)
|
||||
######################################################################
|
||||
{
|
||||
my $fh = shift || confess;
|
||||
my $on_close = shift;
|
||||
my $on_debug_print = shift;
|
||||
|
||||
my $buffer;
|
||||
my $rc = sysread($fh, $buffer, 512);
|
||||
|
||||
if (!defined($rc))
|
||||
{
|
||||
if ($on_debug_print) { &$on_debug_print("socket_read $!"); }
|
||||
return undef;
|
||||
}
|
||||
|
||||
if ($rc == 0)
|
||||
{
|
||||
if ($on_debug_print) { &$on_debug_print('socket_read close'); }
|
||||
|
||||
if ($on_close) { &$on_close($fh); }
|
||||
else { close($fh) || confess; }
|
||||
return undef;
|
||||
|
||||
# Do not call close($fh), this will hang the process.
|
||||
# Socket is automatically closed when the last reference is freed.
|
||||
# $irc->removefh($fh) || confess;
|
||||
# return;
|
||||
}
|
||||
|
||||
$buffer =~ s/\s+$//;
|
||||
if ($on_debug_print) { &$on_debug_print("socket_read rc=$rc buffer=[$buffer]"); }
|
||||
return $buffer;
|
||||
}
|
||||
|
||||
######################################################################
|
||||
sub socket_create_listening($)
|
||||
######################################################################
|
||||
{
|
||||
my $config = shift || confess;
|
||||
|
||||
my $filename = $config->{'ircbot_notify_sock'};
|
||||
return undef if (!$filename);
|
||||
|
||||
unlink($filename);
|
||||
my $uaddr = sockaddr_un($filename) || die "sockaddr_un: $!";
|
||||
my $proto = getprotobyname('tcp') || die "getprotobyname: $!";
|
||||
my $fh;
|
||||
socket($fh, PF_UNIX,SOCK_STREAM, 0) || die "socket: $!";
|
||||
bind ($fh, $uaddr) || die "bind: $!";
|
||||
listen($fh, SOMAXCONN) || die "listen: $!";
|
||||
|
||||
return $fh;
|
||||
}
|
||||
|
||||
######################################################################
|
||||
1;
|
||||
######################################################################
|
||||
159
MOD/PublicHandler.pm
Normal file
159
MOD/PublicHandler.pm
Normal file
|
|
@ -0,0 +1,159 @@
|
|||
######################################################################
|
||||
#
|
||||
# $Id: PublicHandler.pm 159 2009-10-30 11:32:21Z root $
|
||||
#
|
||||
# Copyright 2007 - 2009 Roman Racine
|
||||
# Copyright 2009 Alexander Bartolich
|
||||
#
|
||||
# This program is free software; you can redistribute it and/or modify
|
||||
# it under the terms of the GNU General Public License as published by
|
||||
# the Free Software Foundation; either version 3 of the License, or
|
||||
# (at your option) any later version.
|
||||
#
|
||||
######################################################################
|
||||
package MOD::PublicHandler;
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
use Carp qw(confess);
|
||||
use CGI();
|
||||
use MOD::Utils;
|
||||
use MOD::Displaylib;
|
||||
|
||||
=pod
|
||||
|
||||
=head1 NAME
|
||||
|
||||
MOD::PublicHandler
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This module provides public access to the moderation database. Only things which should
|
||||
be viewable to the public. Data which should only be accessable or changeable by the
|
||||
moderators cannot be retrieved, manipulated whith this module. Use MOD::Handler instead.
|
||||
|
||||
=head1 REQUIREMENTS
|
||||
|
||||
MOD:*
|
||||
CGI
|
||||
News::Article
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Roman Racine <roman.racine@gmx.net>
|
||||
|
||||
|
||||
=head1 VERSION
|
||||
|
||||
2007-11-24
|
||||
|
||||
=cut
|
||||
|
||||
$MOD::PublicHandler::VERSION = 0.04;
|
||||
my %config;
|
||||
my $sql_time_format = '"%d.%m.%Y, %H:%i:%s"';
|
||||
1;
|
||||
|
||||
=pod
|
||||
|
||||
=head1 new
|
||||
|
||||
constructor
|
||||
|
||||
usage:
|
||||
|
||||
my $handler = MOD::PublicHandler->new('/path/to/the/config/file');
|
||||
$handler->run();
|
||||
|
||||
=cut
|
||||
|
||||
sub new {
|
||||
my ($class,$filename) = @_;
|
||||
my $self = {};
|
||||
%config = MOD::Utils::read_public_config($filename);
|
||||
$self->{'q'} = new CGI;
|
||||
|
||||
# 0 -> get unpriviledged (i.e. non-moderator) access to the displaylib
|
||||
$self->{'d'} = MOD::Displaylib->new(\%config,0);
|
||||
$self->{'config'} = \%config;
|
||||
bless $self, $class;
|
||||
return $self;
|
||||
}
|
||||
|
||||
=pod
|
||||
|
||||
=head1 run
|
||||
|
||||
usage:
|
||||
|
||||
my $handler = MOD::PublicHandler->new('/path/to/the/config/file');
|
||||
$handler->run();
|
||||
|
||||
This is the main handling routine, this method will get the arguments from the browser,
|
||||
parse it and handle it, calling the necessary routines.
|
||||
|
||||
=cut
|
||||
|
||||
sub run {
|
||||
my $self = shift;
|
||||
my $start;
|
||||
|
||||
my $q = $self->{'q'} || confess 'No "q" in $self';
|
||||
|
||||
#get the parameters, check for illegal values
|
||||
(undef,$start) = split (',',$ENV{'QUERY_STRING'});
|
||||
if (!defined($start) || $start !~ /^\d+$/) {
|
||||
$start = 0;
|
||||
}
|
||||
|
||||
my $id = $q->param('id');
|
||||
$id = 0 unless($id);
|
||||
|
||||
#call the handling routines
|
||||
if ($q->param('action.Show')) {
|
||||
$self->display_single($start,$id);
|
||||
} else {
|
||||
$self->display_overview($start,$id);
|
||||
}
|
||||
return;
|
||||
}
|
||||
|
||||
|
||||
########## The following methods are for internal use only #####################
|
||||
|
||||
#method to display an overview over a number of postings using a table format.
|
||||
sub display_overview {
|
||||
my ($self,$start,$id) = @_;
|
||||
|
||||
$self->{'d'}->display_table(
|
||||
-status => 'posted',
|
||||
-start => $start,
|
||||
-no_of_elements => $self->{'config'}->{'display_per_page'},
|
||||
-overviewref => [
|
||||
'Sender',
|
||||
'Subject',
|
||||
"Date_Format(Datum,$sql_time_format) AS 'Incoming Date'",
|
||||
"Date_Format(Moddatum,$sql_time_format) AS 'Decision Date'"
|
||||
],
|
||||
-decisionref => [ 'Show' ],
|
||||
-title => 'Overview of Approved Posts',
|
||||
-cmd => 'bla',
|
||||
-startrange => $id
|
||||
);
|
||||
return;
|
||||
}
|
||||
|
||||
#method to display a single article given by an ID.
|
||||
sub display_single {
|
||||
my ($self,$start,$id) = @_;
|
||||
my %args = (
|
||||
-status => 'posted',
|
||||
-id => $id,
|
||||
-headerref => [ 'From', 'Reply-To', 'Subject', 'Date', 'Newsgroups' ],
|
||||
-decisionref => [],
|
||||
-fullheader => 0,
|
||||
);
|
||||
$self->{'d'}->display_article(%args);
|
||||
return;
|
||||
}
|
||||
|
||||
131
MOD/ReadMail.pm
Normal file
131
MOD/ReadMail.pm
Normal file
|
|
@ -0,0 +1,131 @@
|
|||
######################################################################
|
||||
#
|
||||
# $Id: ReadMail.pm 293 2011-06-21 16:01:33Z alba $
|
||||
#
|
||||
# Copyright 2009-2011 Alexander Bartolich
|
||||
#
|
||||
# This program is free software; you can redistribute it and/or modify
|
||||
# it under the terms of the GNU General Public License as published by
|
||||
# the Free Software Foundation; either version 3 of the License, or
|
||||
# (at your option) any later version.
|
||||
#
|
||||
######################################################################
|
||||
package MOD::ReadMail;
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
use Carp qw( confess );
|
||||
use News::Article();
|
||||
use Mail::SpamAssassin();
|
||||
use MOD::Spamfilter();
|
||||
use MOD::DBIUtils();
|
||||
|
||||
######################################################################
|
||||
sub new()
|
||||
######################################################################
|
||||
{
|
||||
my ( $class, $configref ) = @_;
|
||||
my $self = {};
|
||||
|
||||
$self->{'config'} = $configref || confess;
|
||||
$self->{'spamutil'} = MOD::Spamfilter->new($configref) || confess;
|
||||
$self->{'db'} = MOD::DBIUtils->new($configref) || confess;
|
||||
|
||||
bless $self, $class;
|
||||
return $self;
|
||||
}
|
||||
|
||||
######################################################################
|
||||
sub run_spamassassin($$)
|
||||
{
|
||||
my ( $self, $article ) = @_;
|
||||
|
||||
my $spamutil = $self->{'spamutil'} || confess 'No "spamutil" in $self';
|
||||
|
||||
# Temporarily redirect STDOUT and STDERR to /dev/null to ignore
|
||||
# diagnostics printed by Spamassassin.
|
||||
# Note: SAVE_STDOUT and SAVE_STDERR must be handles.
|
||||
# ">&$savestdout" does not work, i.e. it will not restore stdout.
|
||||
|
||||
open(SAVE_STDOUT, ">&STDOUT") or warn "Failed to dup STDOUT: $!";
|
||||
open(SAVE_STDERR, ">&STDERR") or warn "Failed to dup STDOUT: $!";
|
||||
open(STDOUT, '/dev/null') or warn $!;
|
||||
open(STDERR, '/dev/null') or warn $!;
|
||||
my $score = $spamutil->spamfilter_spamassassin($article);
|
||||
open(STDOUT, ">&SAVE_STDOUT") or warn $!;
|
||||
open(STDERR, ">&SAVE_STDERR") or warn $!;
|
||||
close SAVE_STDOUT;
|
||||
close SAVE_STDERR;
|
||||
|
||||
return $score;
|
||||
}
|
||||
|
||||
######################################################################
|
||||
sub add_article($$;$)
|
||||
######################################################################
|
||||
{
|
||||
my ( $self, $article, $status ) = @_;
|
||||
|
||||
# broken spam postings
|
||||
return 0 if ($article->bytes() <= 2);
|
||||
|
||||
my $config = $self->{'config'} || confess 'No "config" in $self';
|
||||
my $db = $self->{'db'} || confess 'No "db" in $self';
|
||||
my $spamutil = $self->{'spamutil'} || confess 'No "spamutil" in $self';
|
||||
|
||||
if (!defined($article->header('Newsgroups')))
|
||||
{
|
||||
my $group = $config->{'moderated_group'} || confess 'No "moderated_group" in config.';
|
||||
$article->set_headers('Newsgroups', $group);
|
||||
}
|
||||
|
||||
if ($config->{'followup_to'} && !$article->header('Followup-To'))
|
||||
{
|
||||
$article->set_headers('Followup-To', $config->{'followup_to'});
|
||||
}
|
||||
|
||||
my $score = 0;
|
||||
if (!$status)
|
||||
{
|
||||
if ($spamutil->blacklist($article))
|
||||
{
|
||||
$score = 100;
|
||||
$db->enter_table($article, 'spam', $score);
|
||||
return 0;
|
||||
}
|
||||
|
||||
if ($config->{'spamassassin'})
|
||||
{
|
||||
$score += $self->run_spamassassin($article);
|
||||
}
|
||||
|
||||
if ($config->{'subjectcheck'} and
|
||||
$db->check_subject($article->header('subject')))
|
||||
{
|
||||
my $subjectscore = $config->{'subjectscore'};
|
||||
$article->add_headers('X-Subject-Test', $subjectscore);
|
||||
$score += $subjectscore;
|
||||
}
|
||||
|
||||
if ($config->{'attachmentcheck'})
|
||||
{
|
||||
$score += $spamutil->spamfilter_attachment($article);
|
||||
}
|
||||
|
||||
if ($config->{'langcheck'})
|
||||
{
|
||||
$score += $spamutil->spamfilter_language($article);
|
||||
}
|
||||
|
||||
$status = 'spam' if ($score >= 5);
|
||||
}
|
||||
|
||||
$status = 'pending' unless($status);
|
||||
my $rc = $db->enter_table($article, $status, $score);
|
||||
|
||||
return $rc == 1;
|
||||
}
|
||||
|
||||
######################################################################
|
||||
1;
|
||||
######################################################################
|
||||
142
MOD/Spamfilter.pm
Normal file
142
MOD/Spamfilter.pm
Normal file
|
|
@ -0,0 +1,142 @@
|
|||
######################################################################
|
||||
#
|
||||
# $Id: Spamfilter.pm 147 2009-10-13 14:46:07Z alba $
|
||||
#
|
||||
# Copyright 2007 - 2009 Roman Racine
|
||||
# Copyright 2009 Alexander Bartolich
|
||||
#
|
||||
# This program is free software; you can redistribute it and/or modify
|
||||
# it under the terms of the GNU General Public License as published by
|
||||
# the Free Software Foundation; either version 3 of the License, or
|
||||
# (at your option) any later version.
|
||||
#
|
||||
######################################################################
|
||||
#
|
||||
# this is a spamfilter which checks incoming mails and marks them
|
||||
# as probable Spam.
|
||||
#
|
||||
# Heuristics are added as needed.
|
||||
#
|
||||
# The main function "spamfilter" returns
|
||||
# -1 -> discard (post do de.admin.news.announce)
|
||||
# 0-5 -> no spam,
|
||||
# >5 -> spam
|
||||
#
|
||||
######################################################################
|
||||
package MOD::Spamfilter;
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
use News::Article;
|
||||
use Mail::SpamAssassin;
|
||||
use Text::Language::Guess;
|
||||
|
||||
$MOD::Spamfilter::VERSION = 0.02;
|
||||
|
||||
sub spamfilter;
|
||||
sub blacklist;
|
||||
sub spamlearn;
|
||||
sub new($);
|
||||
1;
|
||||
|
||||
sub new($) {
|
||||
my (undef,$configref) = @_;
|
||||
my $self = {};
|
||||
$self->{'config'} = $configref;
|
||||
bless $self;
|
||||
return $self;
|
||||
}
|
||||
|
||||
|
||||
sub spamfilter_attachment {
|
||||
my ($self,$article) = @_;
|
||||
my $score = 0;
|
||||
if (defined($article->header('Content-Type')) and $article->header('Content-Type') =~
|
||||
/^multipart\/(?:mixed|alternative);.+boundary="(.+?)"$/s) {
|
||||
my @parts = split($1,(join "\n",$article->body()));
|
||||
for my $part (@parts) {
|
||||
if ($part =~ /^\r?\n?Content-Type: (image|video|audio|application|text\/html)/) {
|
||||
$score = $self->{'config'}->{'attachmentscore'};
|
||||
last;
|
||||
}
|
||||
}
|
||||
}
|
||||
$article->add_headers('X-Attachment-Test',$score);
|
||||
return $score;
|
||||
}
|
||||
|
||||
|
||||
sub spamfilter_language {
|
||||
my ($self,$article) = @_;
|
||||
my $guesser = Text::Language::Guess->new(languages => ['en',$self->{'config'}->{'lang'}]);
|
||||
my @messagebody = $article->body();
|
||||
my $score = 0;
|
||||
my $lang = $guesser->language_guess_string(join "\n",@messagebody);
|
||||
if (!defined($lang) or $lang ne $self->{'config'}->{'lang'}) {
|
||||
$score = $self->{'config'}->{'langscore'};
|
||||
}
|
||||
$article->add_headers('X-Lang-Test',$score);
|
||||
return $score;
|
||||
}
|
||||
|
||||
sub spamfilter_spamassassin {
|
||||
my ($self,$article) = @_;
|
||||
# use spamassassin
|
||||
my $spamtest = Mail::SpamAssassin->new();
|
||||
my @messageheader = $article->headers();
|
||||
my @messagebody = $article->body();
|
||||
my $header = join "\n",@messageheader;
|
||||
my $body = join "\n",@messagebody;
|
||||
my $status = $spamtest->check_message_text($header . $body);
|
||||
my $score = $status->get_score();
|
||||
$article->add_headers('X-Spamassassin-Test',$score);
|
||||
return $score;
|
||||
}
|
||||
|
||||
sub blacklist {
|
||||
my ($self,$article) = @_;
|
||||
return 1 if ($article->header('Newsgroups') =~ /de.admin.news.announce/);
|
||||
return 1 if (defined($article->header('Newsgroups')) and
|
||||
$article->header('Newsgroups') !~ /$self->{'config'}->{'moderated_group'}/);
|
||||
return 1 if (!defined($article->header('From')));
|
||||
return 1 if (length($article->header('From')) < 2);
|
||||
return 1 if ($article->bytes() > 100*1024);
|
||||
# kaputte Postings
|
||||
for my $headerline (qw(From Reply-To Subject Message-ID)) {
|
||||
if (defined ($article->header($headerline)) and
|
||||
length($article->header($headerline)) > 1019) {
|
||||
return 1;
|
||||
}
|
||||
}
|
||||
if (defined $self->{'config'}->{'blacklistfile'}) {
|
||||
my $header = join "\n",$article->headers();
|
||||
open(my $blacklistfile, $self->{'config'}->{'blacklistfile'}) or die $!;
|
||||
while (<$blacklistfile>) {
|
||||
chomp;
|
||||
next if (length($_) <= 2);
|
||||
if ($header =~ /$_/s) {
|
||||
close $blacklistfile;
|
||||
return 1;
|
||||
}
|
||||
}
|
||||
close $blacklistfile;
|
||||
}
|
||||
return 0;
|
||||
}
|
||||
|
||||
sub spamlearn {
|
||||
my ($input,$isspam) = @_;
|
||||
return;
|
||||
# my $message = Mail::SpamAssassin::Message->new({'message' => $input});
|
||||
# my $spamtest = new Mail::SpamAssassin ({
|
||||
# 'rules_filename' => '/etc/spamassassin.rules',
|
||||
# 'userprefs_filename' => $ENV{'HOME'}. '/.spamassassin/user_prefs'
|
||||
# });
|
||||
# my $mail = $spamtest->parse($message);
|
||||
# my $status = $spamtest->learn($mail,undef,$isspam,0);
|
||||
# $status->finish();
|
||||
|
||||
# my $spamobj = Mail::SpamAssassin->new();
|
||||
# print defined $spamobj,"\n";
|
||||
# $spamobj->learn($message,undef,$isspam,0);
|
||||
}
|
||||
245
MOD/Utils.pm
Normal file
245
MOD/Utils.pm
Normal file
|
|
@ -0,0 +1,245 @@
|
|||
######################################################################
|
||||
#
|
||||
# $Id: Utils.pm 272 2010-05-28 19:46:29Z root $
|
||||
#
|
||||
# Copyright 2007-2009 Roman Racine
|
||||
# Copyright 2009-2010 Alexander Bartolich
|
||||
#
|
||||
# This program is free software; you can redistribute it and/or modify
|
||||
# it under the terms of the GNU General Public License as published by
|
||||
# the Free Software Foundation; either version 3 of the License, or
|
||||
# (at your option) any later version.
|
||||
#
|
||||
######################################################################
|
||||
#
|
||||
# This package contains some frequently used routines
|
||||
#
|
||||
######################################################################
|
||||
package MOD::Utils;
|
||||
|
||||
use warnings;
|
||||
use strict;
|
||||
use Carp qw( confess );
|
||||
use News::Article();
|
||||
use I18N::AcceptLanguage();
|
||||
|
||||
use MOD::lang::en_us();
|
||||
|
||||
@MOD::Utils::ISA = qw(Exporter);
|
||||
@MOD::Utils::EXPORT = qw();
|
||||
@MOD::Utils::EXPORT_OK = qw(
|
||||
read_public_config
|
||||
read_private_config
|
||||
);
|
||||
|
||||
######################################################################
|
||||
|
||||
our @SUPPORTED_LANG;
|
||||
our %SUPPORTED_LANG;
|
||||
|
||||
# cache of public configuration file
|
||||
# key = filename, value = [ mtime, r_config ]
|
||||
our %CONFIG_CACHE;
|
||||
|
||||
######################################################################
|
||||
sub get_cache_entry($)
|
||||
######################################################################
|
||||
{
|
||||
my $filename = shift || confess 'No parameter $filename';
|
||||
my $r_cache = $CONFIG_CACHE{$filename};
|
||||
return undef if (!$r_cache);
|
||||
|
||||
my ($dev, $ino, $mode, $nlink, $uid, $gid, $rdev, $size, $atime,
|
||||
$mtime, $ctime, $blksize, $blocks) = stat($filename);
|
||||
die "Can't access $filename:$!" if (!$mtime);
|
||||
|
||||
return ($r_cache->[0] < $mtime) ? undef : $r_cache->[1];
|
||||
}
|
||||
|
||||
######################################################################
|
||||
sub add_cache_entry($$)
|
||||
######################################################################
|
||||
{
|
||||
my $filename = shift || confess 'No parameter $filename';
|
||||
my $r_config = shift || confess 'No parameter $r_config';
|
||||
|
||||
$CONFIG_CACHE{$filename} = [ time(), $r_config ];
|
||||
}
|
||||
|
||||
######################################################################
|
||||
sub read_config_file($$)
|
||||
######################################################################
|
||||
{
|
||||
my $filename = shift || confess 'No parameter $filename';
|
||||
my $r_hash = shift || confess 'No parameter $r_hash';
|
||||
|
||||
my $conf;
|
||||
open($conf, '<', $filename) ||
|
||||
die "Can't open configuration file: \n$!\n$filename";
|
||||
while(my $line = <$conf>)
|
||||
{
|
||||
next if ($line =~ /^\s*#/);
|
||||
my ($name, $val) = split (/[ \t]*=[ \t]*/, $line, 2);
|
||||
# ignore undefined $val and zero-length $val
|
||||
next if (!$val);
|
||||
$name =~ s/^\s+//;
|
||||
$val =~ s/\s+$//;
|
||||
$val =~ s/^"(.*)"$/$1/;
|
||||
$r_hash->{$name} = $val;
|
||||
}
|
||||
}
|
||||
|
||||
######################################################################
|
||||
# Read the public config file, returns a hash of settings.
|
||||
######################################################################
|
||||
sub read_public_config($)
|
||||
######################################################################
|
||||
{
|
||||
my $filename = shift || confess 'No parameter $filename';
|
||||
my $r_config = get_cache_entry($filename);
|
||||
if ($r_config) { return %$r_config; }
|
||||
|
||||
my %config_vars =
|
||||
(
|
||||
'mysql_password' => $ENV{'mysql_password'}
|
||||
);
|
||||
read_config_file($filename, \%config_vars);
|
||||
add_cache_entry($filename, \%config_vars);
|
||||
return %config_vars;
|
||||
}
|
||||
|
||||
######################################################################
|
||||
# Read the private config file, returns a hash of settings.
|
||||
#
|
||||
# The function first reads the public file to read the values of
|
||||
# 'UID' and 'priv_config_file'.
|
||||
#
|
||||
# The function dies
|
||||
# - if 'UID' or 'priv_config_file' are not defined
|
||||
# - if user id (variable "$<") does not match the setting of "UID"
|
||||
# - if the private file cannot be opened
|
||||
######################################################################
|
||||
sub read_private_config($)
|
||||
######################################################################
|
||||
{
|
||||
my $filename = shift || confess 'No parameter $filename';
|
||||
my %config_vars = read_public_config($filename);
|
||||
|
||||
my $cfg_uid = $config_vars{'UID'} ||
|
||||
die 'No "UID" in public configuration file $filename"';
|
||||
if ($< != $cfg_uid)
|
||||
{
|
||||
die "Execution of this function is not allowed for user ID $<!\n";
|
||||
}
|
||||
|
||||
my $priv_file = $config_vars{'priv_config_file'} ||
|
||||
die "No 'priv_config_file' in public configuration file $filename";
|
||||
read_config_file($priv_file, \%config_vars);
|
||||
return %config_vars;
|
||||
}
|
||||
|
||||
######################################################################
|
||||
sub get_supported_translators()
|
||||
######################################################################
|
||||
{
|
||||
return @SUPPORTED_LANG if (@SUPPORTED_LANG);
|
||||
|
||||
my $pkgname = __PACKAGE__; # value of __PACKAGE__ is "MOD::Utils"
|
||||
$pkgname =~ s#.*::##g; # reduce to "Utils"
|
||||
my $pkgdir = __FILE__; # __FILE__ is "/srv/www/huhu/MOD/Utils.pm"
|
||||
$pkgdir =~ s#$pkgname\.pm$##; # reduce to "/srv/www/huhu/MOD/"
|
||||
$pkgdir .= 'lang';
|
||||
|
||||
# String constants in this software are written in American English.
|
||||
@SUPPORTED_LANG = ( 'en-us' );
|
||||
%SUPPORTED_LANG = ( 'en-us' => undef );
|
||||
|
||||
my $dirhandle;
|
||||
|
||||
opendir($dirhandle, $pkgdir) || die "opendir $pkgdir: $!";
|
||||
for my $lang( grep { /^\w+\.pm$/ && -f "$pkgdir/$_" } readdir($dirhandle) )
|
||||
{
|
||||
$lang =~ s#\.pm$##;
|
||||
# Perl dows not allow '-' in module names, so we use '_' instead.
|
||||
# The strings in HTTP_ACCEPT_LANGUAGE use '-', however.
|
||||
$lang =~ s#_#-#g;
|
||||
$SUPPORTED_LANG{$lang} = undef;
|
||||
push @SUPPORTED_LANG, $lang;
|
||||
}
|
||||
closedir($dirhandle);
|
||||
|
||||
return @SUPPORTED_LANG;
|
||||
}
|
||||
|
||||
######################################################################
|
||||
sub get_translator_language($$)
|
||||
######################################################################
|
||||
{
|
||||
my $lang = shift;
|
||||
my $negotiate = shift;
|
||||
|
||||
get_supported_translators();
|
||||
|
||||
if ($negotiate && exists($ENV{ 'HTTP_ACCEPT_LANGUAGE' }))
|
||||
{
|
||||
# Sample value for HTTP_ACCEPT_LANGUAGE:
|
||||
# de-at,en-us;q=0.7,en;q=0.3
|
||||
my $a = I18N::AcceptLanguage->new( $lang );
|
||||
my $n = $a->accepts($ENV{HTTP_ACCEPT_LANGUAGE}, \@SUPPORTED_LANG);
|
||||
|
||||
$lang = $n if (defined($n) && exists($SUPPORTED_LANG{ $n }));
|
||||
}
|
||||
|
||||
if ($lang)
|
||||
{
|
||||
unless(exists($SUPPORTED_LANG{ $lang }))
|
||||
{
|
||||
die "Unsupported language '$lang' (choose one of " .
|
||||
join(', ', @SUPPORTED_LANG) . ')';
|
||||
}
|
||||
return $lang;
|
||||
}
|
||||
|
||||
return $SUPPORTED_LANG[0];
|
||||
}
|
||||
|
||||
######################################################################
|
||||
sub get_translator($)
|
||||
######################################################################
|
||||
{
|
||||
my $lang = shift;
|
||||
if ($lang)
|
||||
{
|
||||
unless(exists($SUPPORTED_LANG{ $lang }))
|
||||
{
|
||||
die "Unsupported language '$lang' (choose one of " .
|
||||
join(', ', @SUPPORTED_LANG) . ')';
|
||||
}
|
||||
|
||||
# Perl dows not allow '-' in module names, so we use '_' instead.
|
||||
# The strings in HTTP_ACCEPT_LANGUAGE use '-', however.
|
||||
$lang =~ s#-#_#g;
|
||||
|
||||
my $module = __PACKAGE__; # value of __PACKAGE__ is "MOD::Utils"
|
||||
$module =~ s#::[^:]+$##g; # reduce to "MOD"
|
||||
$module .= '::lang::' . $lang; # extend to "MOD::lang::en"
|
||||
|
||||
eval "use $module;";
|
||||
if (length($@) == 0)
|
||||
{
|
||||
no strict;
|
||||
my $get = eval '*{$' . $module . '::{"get_translator"}}{"CODE"}';
|
||||
if (length($@) == 0)
|
||||
{
|
||||
my $trans = return $get->($lang);
|
||||
return $trans if $trans;
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
return MOD::lang::en_us::get_translator($lang);
|
||||
}
|
||||
|
||||
######################################################################
|
||||
1;
|
||||
######################################################################
|
||||
104
MOD/lang/de.pm
Normal file
104
MOD/lang/de.pm
Normal file
|
|
@ -0,0 +1,104 @@
|
|||
#####################################################################
|
||||
#
|
||||
# $Id: de.pm 298 2011-09-04 11:11:33Z root $
|
||||
#
|
||||
# Copyright 2009 Roman Racine
|
||||
# Copyright 2009-2011 Alexander Bartolich
|
||||
#
|
||||
# This program is free software; you can redistribute it and/or modify
|
||||
# it under the terms of the GNU General Public License as published by
|
||||
# the Free Software Foundation; either version 3 of the License, or
|
||||
# (at your option) any later version.
|
||||
#
|
||||
######################################################################
|
||||
#
|
||||
# This file is encoded in iso-8859-1
|
||||
#
|
||||
######################################################################
|
||||
package MOD::lang::de;
|
||||
|
||||
use warnings;
|
||||
use strict;
|
||||
|
||||
######################################################################
|
||||
use constant TRANS =>
|
||||
######################################################################
|
||||
{
|
||||
'_ALREADY_HANDLED' => 'Dieser Eintrag wurde bereits von einem anderen Moderator bearbeitet.',
|
||||
'Approved Messages' => 'Zugelassene Postings',
|
||||
'Approved' => 'Zugelassen',
|
||||
'Approve' => 'Posten',
|
||||
'_ARRIVAL_NOTICE_BODY' => "In der Moderationsqueue sind noch eines oder mehrere Postings\nvon dir unbearbeitet. Dies ist eine automatische Nachricht.\n",
|
||||
'_ARRIVAL_NOTICE_SUBJECT' => '[%s] Eingangsbestaetigung',
|
||||
'article_sender' => 'Sender',
|
||||
'article_status' => 'Status',
|
||||
'article_subject' => 'Betreff',
|
||||
'Available Actions' => 'Mögliche Aktionen',
|
||||
'Back' => 'Zurück',
|
||||
'Brief Headers' => 'Header verbergen',
|
||||
_CROSSPOSTED => 'Vorsicht, dieses Posting ist in mehr als zwei NGs crossgepostet!',
|
||||
'Date' => 'Datum',
|
||||
'Decision Date' => 'Entscheidungsdatum',
|
||||
'Delete and save reason' => 'Löschen und Begründung speichern',
|
||||
'Delete and save reason' => 'Löschen und Begründung speichern',
|
||||
'Deleted' => 'Gelöscht',
|
||||
'Deleted Posts' => 'Gelöschte Postings',
|
||||
'Delete' => 'Löschen',
|
||||
'Delete Post' => 'Posting löschen',
|
||||
'error_count' => 'Fehleranzahl',
|
||||
'error_date' => 'Datum',
|
||||
'Error' => 'Fehler',
|
||||
_ERROR_GONE => 'Die Fehlermeldung liegt nicht mehr vor, der Fehler ist behoben.',
|
||||
_ERROR_INVALID_ADDRESS => 'Ungültige Adresse, Versand eines Mails nicht möglich.',
|
||||
'error_message' => 'Fehlermeldung',
|
||||
'Error Messages' => 'Fehlermeldungen',
|
||||
'_EXPLAIN_REASON' => 'Hier kann ein Grund für die Löschung des Artikels angegeben werden. Dieser Text ist nur für die übrigen Moderationsmitglieder sichtbar.',
|
||||
'Incoming Date' => 'Eingangsdatum',
|
||||
'Messages' => 'Postings',
|
||||
'Next page' => 'Vorwärts blättern',
|
||||
'No matching records available.' => 'Kein passender Datensatz vorhanden.',
|
||||
'No reason stored in database!' => 'Keine Begründung in der Datenbank vorhanden!',
|
||||
'No Spam' => 'Kein Spam',
|
||||
'No subject' => 'Kein Betreff',
|
||||
'Overview of Approved Posts' => 'Überblick über die zugelassenen Postings',
|
||||
'Pending' => 'Offen',
|
||||
'Pending Posts' => 'Offene Moderationsentscheidungen',
|
||||
'Posted' => 'Gesendet',
|
||||
'Posted Messages' => 'Gesendete Postings',
|
||||
'Previous page' => 'Zurück blättern',
|
||||
'Put back in queue' => 'In Moderationsqueue zurück',
|
||||
'Reason' => 'Begründung',
|
||||
'Rejected' => 'Abgewiesen',
|
||||
'Rejected Posts' => 'Zurückgewiesene Postings',
|
||||
'Reject Post' => 'Posting zurückweisen',
|
||||
'Reject' => 'Zurückweisen',
|
||||
'Reply' => 'Antwort',
|
||||
'Selected Article' => 'Gewählter Artikel',
|
||||
'Sender' => 'Absender',
|
||||
'Send Mail' => 'Mail verschicken',
|
||||
'Show' => 'Anzeigen',
|
||||
'Show Error Message' => 'Fehlermeldung anzeigen',
|
||||
'Show Post' => 'Posting anzeigen',
|
||||
'Show Reply' => 'Antwort anzeigen',
|
||||
'Spam Folder' => 'Spamordner',
|
||||
'Subject' => 'Betreff',
|
||||
'_SUBTITLE_APPROVED' => 'Zugelassene aber noch nicht gesendete Postings.',
|
||||
'_SUBTITLE_DELETED' => 'Ignorierte Postings.',
|
||||
'_SUBTITLE_ERROR' => 'Zugelassene Postings die nicht gesendet werden konnten. Wird automatisch wiederholt.',
|
||||
'_SUBTITLE_PENDING' => 'Postings die auf eine Entscheidung warten.',
|
||||
'_SUBTITLE_POSTED' => 'Zugelassene Postings die zum Newsserver gesendet wurden.',
|
||||
'_SUBTITLE_REJECTED' => 'Abgelehnte Postings, bei denen dem Sender eine Begründung geschickt wurde.',
|
||||
'_SUBTITLE_SPAM' => 'Postings die vom Spamfilter oder einem Moderator als Spam kategorisiert wurden.',
|
||||
'%s wrote:' => '%s schrieb:',
|
||||
'Your post regarding' => 'Dein Posting zum Thema',
|
||||
};
|
||||
|
||||
sub get_translator($)
|
||||
{
|
||||
return sub {
|
||||
my $result = TRANS->{$_[0]};
|
||||
return $result ? $result : $_[0];
|
||||
};
|
||||
}
|
||||
|
||||
1;
|
||||
42
MOD/lang/de_ch.pm
Normal file
42
MOD/lang/de_ch.pm
Normal file
|
|
@ -0,0 +1,42 @@
|
|||
######################################################################
|
||||
#
|
||||
# $Id: de_ch.pm 147 2009-10-13 14:46:07Z alba $
|
||||
#
|
||||
# Copyright 2009 Roman Racine
|
||||
# Copyright 2009 Alexander Bartolich
|
||||
#
|
||||
# This program is free software; you can redistribute it and/or modify
|
||||
# it under the terms of the GNU General Public License as published by
|
||||
# the Free Software Foundation; either version 3 of the License, or
|
||||
# (at your option) any later version.
|
||||
#
|
||||
######################################################################
|
||||
#
|
||||
# This file is encoded in iso-8859-1
|
||||
#
|
||||
######################################################################
|
||||
package MOD::lang::de_ch;
|
||||
|
||||
use warnings;
|
||||
use strict;
|
||||
use Carp qw( confess );
|
||||
use MOD::lang::de();
|
||||
|
||||
use constant TRANS => {
|
||||
'Pending' => 'Pendent',
|
||||
'Pending Posts' => 'Pendente Moderationsentscheidungen',
|
||||
};
|
||||
|
||||
sub get_translator($)
|
||||
{
|
||||
my $de = MOD::lang::de::get_translator(@_) || confess;
|
||||
return sub {
|
||||
my $result = TRANS->{$_[0]};
|
||||
return $result if ($result);
|
||||
$result = $de->(@_);
|
||||
return $result if ($result);
|
||||
return $_[0];
|
||||
};
|
||||
}
|
||||
|
||||
1;
|
||||
22
MOD/lang/de_de.pm-disable
Normal file
22
MOD/lang/de_de.pm-disable
Normal file
|
|
@ -0,0 +1,22 @@
|
|||
#!/usr/bin/perl -w
|
||||
#
|
||||
# $Id: de_de.pm-disable 64 2009-09-02 19:42:41Z alba $
|
||||
#
|
||||
# This file is encoded in iso-8859-1
|
||||
#
|
||||
package MOD::lang::de_de;
|
||||
|
||||
use warnings;
|
||||
use strict;
|
||||
use MOD::lang::de_at();
|
||||
|
||||
@MOD::Utils::ISA = qw(Exporter);
|
||||
@MOD::Utils::EXPORT = qw();
|
||||
@MOD::Utils::EXPORT_OK = qw( get_translator );
|
||||
|
||||
sub get_translator($)
|
||||
{
|
||||
return MOD::lang::de_at::get_translator(@_);
|
||||
}
|
||||
|
||||
1;
|
||||
54
MOD/lang/en_us.pm
Normal file
54
MOD/lang/en_us.pm
Normal file
|
|
@ -0,0 +1,54 @@
|
|||
######################################################################
|
||||
#
|
||||
# $Id: en_us.pm 273 2010-05-28 21:22:31Z root $
|
||||
#
|
||||
# Copyright 2009 Roman Racine
|
||||
# Copyright 2009-2010 Alexander Bartolich
|
||||
#
|
||||
# This program is free software; you can redistribute it and/or modify
|
||||
# it under the terms of the GNU General Public License as published by
|
||||
# the Free Software Foundation; either version 3 of the License, or
|
||||
# (at your option) any later version.
|
||||
#
|
||||
######################################################################
|
||||
#
|
||||
# This file is encoded in iso-8859-1
|
||||
#
|
||||
######################################################################
|
||||
package MOD::lang::en_us;
|
||||
|
||||
use warnings;
|
||||
use strict;
|
||||
|
||||
use constant TRANS => {
|
||||
'_ALREADY_HANDLED' => 'This entry was already handled by another moderator.',
|
||||
'_ARRIVAL_NOTICE_BODY' => "One or more of your posts are pending in the moderation queue.\nThis message was generated automatically.\n",
|
||||
'_ARRIVAL_NOTICE_SUBJECT' => '[%s] Post received',
|
||||
'article_sender' => 'Sender',
|
||||
'article_status' => 'Status',
|
||||
'article_subject' => 'Subject',
|
||||
'_CROSSPOSTED' => 'Note that this message is crossposted to more than two groups!',
|
||||
'error_count' => 'Error Count',
|
||||
'error_date' => 'Date',
|
||||
'_ERROR_GONE' => 'The error message is gone, probably because its cause is fixed.',
|
||||
'_ERROR_INVALID_ADDRESS' => 'Invalid address, can\'t send mail.',
|
||||
'error_message' => 'Error Message',
|
||||
'_EXPLAIN_REASON' => 'Here you can state a reason why the message was deleted. This text is visible only to other members of the moderation team.',
|
||||
'_SUBTITLE_APPROVED' => 'Approved posts that are not sent, yet.',
|
||||
'_SUBTITLE_DELETED' => 'Posts that are silently ignored.',
|
||||
'_SUBTITLE_ERROR' => 'Approved posts that could not be sent. Will be retried automatically.',
|
||||
'_SUBTITLE_PENDING' => 'Posts waiting for your decision.',
|
||||
'_SUBTITLE_POSTED' => 'Approved posts that were sent to the newsserver.',
|
||||
'_SUBTITLE_REJECTED' => 'Posts where the sender was sent a reason why they were not approved.',
|
||||
'_SUBTITLE_SPAM' => 'Posts classified as spam by the spam filter or a moderator.',
|
||||
};
|
||||
|
||||
sub get_translator($)
|
||||
{
|
||||
return sub {
|
||||
my $result = TRANS->{$_[0]};
|
||||
return $result ? $result : $_[0];
|
||||
};
|
||||
}
|
||||
|
||||
1;
|
||||
Loading…
Add table
Add a link
Reference in a new issue