#!/usr/local/bin/perl use warnings; use strict; use MIME::Parser; use MIME::Words qw(:all); use Encode; use CGI; use URI::URL; my $inqueue = (getpwuid($<))[7] . "/Maildir/"; my $rejected = "$inqueue/Rejected"; my $approved = "$inqueue/Approved"; my $q = CGI->new(); if ($q->request_method eq 'POST' && $q->param('approve')) { approve_message2($q->param('name'), $q->param('content')); } elsif ($q->param('view')) { view_message($q->param('view')); } elsif ($q->param('reject')) { reject_message($q->param('reject')); } elsif ($q->param('approve')) { approve_message($q->param('approve')); } else { list_messages(); } sub get_messages { my @messages = read_maildir($inqueue); return @messages; } sub read_maildir { my ($md) = @_; # move new messages (if any) to cur opendir (D, "$md/new") or return (); for (readdir(D)) { next if (/^\.\.?$/); rename("$md/new/$_", "$md/cur/$_:2,"); } closedir(D); my @messages; opendir (D, "$md/cur") or return (); for my $f (readdir(D)) { next unless (-f "$md/cur/$f"); print STDERR "read_maildir: $md/cur/$f\n"; my $parser = MIME::Parser->new(); $parser->output_to_core(1); $parser->tmp_to_core(1); my $entity = $parser->parse_open("$md/cur/$f"); push (@messages, { name => $f, entity => $entity }); } closedir(D); return @messages; } sub list_messages { my (@messages) = get_messages(); print "Content-type: text/html; charset=utf-8\r\n"; print "\r\n"; binmode(STDOUT, ":utf8"); print "\n"; print "
\n"; print "", scalar(@messages), " submissions:
\n"; print "$date | \n"; print "$from | \n"; print "$subject | \n"; print "View | \n"; print "Approve | \n"; print "Reject | \n"; print "
\n"; while (defined (my $l = $io->getline())) { $l = decode($cs, $l); print $l; } print "\n"; $io->close(); } else { print "
Kann MIME-Type ", $entity->mime_type, " nicht parsen
\n"; } print "\n"; print "\n"; } sub reject_message { my ($msg_name) = @_; print STDERR "reject_message: $inqueue/cur/$msg_name -> $rejected/cur/$msg_name\n"; my $rc = rename("$inqueue/cur/$msg_name", "$rejected/cur/$msg_name"); print STDERR "reject_message: result = $rc\n"; print "Content-type: text/html; charset=utf-8\r\n"; print "Refresh: 10; URL=", url("./", $q->url())->abs, "\r\n"; print "\r\n"; binmode(STDOUT, ":utf8"); print "\n"; print "\n"; print "Message rejected
\n"; } else { print "Reject failed: $!
\n"; } print "\n"; print "\n"; } sub approve_message { my ($msg_name) = @_; print "Content-type: text/html; charset=utf-8\r\n"; print "\r\n"; binmode(STDOUT, ":utf8"); print "\n"; print "\n"; print "Kann MIME-Type ", $entity->mime_type, " nicht parsen
\n"; } print "\n"; print "\n"; } sub approve_message2 { my ($msg_name, $msg_content) = @_; my $failure = 0; print STDERR "approve_message2: $inqueue/cur/$msg_name -> $approved/new/$msg_name\n"; print STDERR "approve_message2: length(msg_content) = ", length($msg_content), "\n"; if (open(F, ">", "$approved/tmp/$msg_name") ) { print F "MIME-Version: 1.0\n"; print F "Content-Type: text/plain; charset=UTF-8\n"; print F "Content-Encoding: 8bit\n"; print F "Newsgroups: ", $q->param('newsgroup'), "\n"; print F "Approved: <", $q->remote_user, '@autsch.hjp.at>', "\n"; my $in_header = 1; for (split(/\r?\n/, $msg_content)) { if ($in_header) { print F encode_rfc2047($_), "\n" or $failure = $!; $in_header = 0 if (/^$/); print STDERR "approve_message2: header: $_\n"; } else { print F "$_\n" or $failure = $!; print STDERR "approve_message2: body: $_\n"; } } close(F) or $failure = $!; print STDERR "approve_message2: after close: failure=$failure\n"; unless ($failure) { rename("$approved/tmp/$msg_name", "$approved/new/$msg_name") or $failure = $!; } unless ($failure) { print STDERR "approve_message2: removing $inqueue/cur/$msg_name\n"; unlink("$inqueue/cur/$msg_name") or print STDERR "approve_message2: cannot unlink $inqueue/cur/$msg_name: $!\n"; } } else { $failure = $!; } print STDERR "approve_message2: result = $failure\n"; print "Content-type: text/html; charset=utf-8\r\n"; print "Refresh: 10; URL=", url("./", $q->url())->abs, "\r\n"; print "\r\n"; binmode(STDOUT, ":utf8"); print "\n"; print "\n"; print "Approve failed: $failure
\n"; } else { print "Message approved
\n"; } print "\n"; print "\n"; } =head2 encode_rfc2047 Encode a line almost according to rfc 2047. Currently the maximum length of 75 characters for a single encoded word is not enforced and the maximum line length of 76 characters isn't enforced either. (I'm not sure the latter is actually necessary: RFC 1036 allows header lengths of up to 1000 characters and an implementation which would allow long unencoded headers but only short encoded headers seems a bit strange. But we will see if anybody complains :-) =cut sub encode_rfc2047 { my ($s) = @_; my @w = split(/(\s+)/s, $s); my $lws = ""; my $unsafe = undef; my $e = ""; for my $w (@w) { if ($w =~ /^\s+$/s) { $lws = $w; } elsif ($w =~ /([^\x21-\x7E]|^=\?)/) { # non-ascii or looks like encoded word if (defined($unsafe)) { $unsafe .= $lws . $w; } else { $e .= $lws; $unsafe = $w; } } else { if (defined($unsafe)) { $e .= my_encode_mimeword($unsafe); $e .= $lws; $e .= $w; $unsafe = undef; } else { $e .= $lws; $e .= $w; } } } $e .= my_encode_mimeword($unsafe) if (defined $unsafe); return $e; } =head2 my_encode_mimeword encode a single word. tries both b and q encoding and returns the shorter version. does not yet split the word into multiple encoded_words if the result is longer than 75 characters. =cut sub my_encode_mimeword { my ($unsafe) = @_; my $eq = encode_mimeword(Encode::encode('utf-8', $unsafe), 'q', 'utf-8'); $eq =~ s/ /_/g; my $eb = encode_mimeword(Encode::encode('utf-8', $unsafe), 'b', 'utf-8'); return length($eq) <= length($eb) ? $eq : $eb; }