- signed mails gehen jetzt auch (musste nur in die config rein)
authorheiko
Fri, 07 Sep 2007 22:16:36 +0000
changeset 18 cd800b3f5a6e
parent 17 e9aa9cb9f61f
child 19 a583222ef68e
- signed mails gehen jetzt auch (musste nur in die config rein) - etwas die Config-verarbeitung aufgerÀumt
mimecut.pl
mimes.conf
--- a/mimecut.pl	Fri Sep 07 21:48:38 2007 +0000
+++ b/mimecut.pl	Fri Sep 07 22:16:36 2007 +0000
@@ -2,9 +2,6 @@
 # $Id$
 # $URL$
 #
-# ** Just proof of concept ** to see if we really need to decode all the
-# mime parts.
-#
 
 use strict;
 use warnings;
@@ -12,27 +9,22 @@
 use Fatal qw(:void select);
 use File::Temp qw(tempfile);
 use if $ENV{DEBUG} => "Smart::Comments";
+use File::Basename;
 use FindBin qw($Bin);
 
 sub print_message(*@);
 sub read_message();
-sub pass_mime($$);
-sub forward_to_boundary($*);
+sub pass_mime($);
 sub read_header(*);
+sub process(*;@);
 
-#
-sub process($*;@);
-my $confdir = -f "$Bin/.build" ? $Bin : "/etc/$0";
-my @mimes;
+my $ME = basename $0;
+my $CONFDIR = -f "$Bin/.build" ? $Bin : "/etc/$ME";
 
 $SIG{__WARN__} = sub { print STDERR "### ", @_ };
 
 MAIN: {
 
-    open(my $fh, "< $confdir/mimes.conf")
-        or warn "can't read config!\n";
-    my @mimes = map { chomp; $_ } grep !/(?:^\s*#|^\s*$)/, <$fh>;
-
     # create an r/o tmp file containing the message  for sequential
     # processing and optional failback in face of some processing error
     my $message = read_message();
@@ -45,7 +37,7 @@
 
     # now we start processing but at the beginning - of course
     seek($message, 0, 0);
-    process(\@mimes, $message, boundary => undef);
+    process($message, boundary => undef);
 
     # everything is done, probably some rest is still unprocessed (some
     # epilogue, but this shouldn't be a problem at all
@@ -71,8 +63,8 @@
     }
 }
 
-sub process($*;@) {
-    my ($mimes, $m, %arg) = @_;
+sub process(*;@) {
+    my ($m,      %arg)    = @_;
     my ($header, %header) = read_header($m);
     my ($type, $boundary);
 
@@ -87,7 +79,7 @@
 
     $boundary ||= $arg{boundary};
 
-    if (not $type or pass_mime($type, $mimes)) {
+    if (not $type or pass_mime($type)) {
 
         #warn "passing: " . ($type ? $type : "no mime type") . "\n";
         print $header;
@@ -102,7 +94,7 @@
         print_message($m, to => $boundary);
 
         while (not eof($m)) {
-            process($mimes, $m, boundary => $boundary);
+            process($m, boundary => $boundary);
         }
 
         return;
@@ -130,12 +122,19 @@
 
 }
 
-sub pass_mime($$) {
-    my ($type, $mimes) = @_;
-    local $_ = $type;
-    my $re = join "|",
-        map { $a = $_; $a =~ s/([^\da-z])/\\$1/gi; $a } @$mimes;
-    return m{$re};
+{
+    my $re;
+
+    sub pass_mime($) {
+        my ($type) = @_;
+
+        if (!$re) {
+            open(my $fh, "<$CONFDIR/mimes.conf")
+                or die "can't read $CONFDIR/mimes.conf!\n";
+            $re = qr{@{[join "|", map { chomp; "(?:".quotemeta($_).")" } grep !/(?:^\s*#|^\s*$)/, <$fh>]}};
+        }
+        return $type =~ /$re/;
+    }
 }
 
 sub read_message() {
--- a/mimes.conf	Fri Sep 07 21:48:38 2007 +0000
+++ b/mimes.conf	Fri Sep 07 22:16:36 2007 +0000
@@ -4,6 +4,7 @@
 # All other mime types will NOT be archived!
 
 text/
+/signed
 #text/plain
 #text/html
 #text/css