--- a/hs12 Fri Sep 07 15:25:39 2007 +0000
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,169 +0,0 @@
-#! /usr/bin/perl
-# $Id$
-# $URL$
-#
-# ** Just proof of concept ** to see if we really need to decode all the
-# mime parts.
-#
-
-use strict;
-use warnings;
-
-use Fatal qw(:void select);
-use File::Temp qw(tempfile);
-use if $ENV{DEBUG} => "Smart::Comments";
-use FindBin qw($Bin);
-
-sub print_message(*@);
-sub read_message();
-sub pass_mime($$);
-sub forward_to_boundary($*);
-sub read_header(*);
-
-#
-sub process($*;@);
-my $confdir = -f "$Bin/.build" ? $Bin : "/etc/$0";
-my @mimes;
-
-$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();
-
- # during processing everything is printed into some tmp file
- # - this way we can abort processing at any time and just send
- # the above temporary file down the river
- my $tmpout = tempfile();
- my $stdout = select $tmpout;
-
- # now we start processing but at the beginning - of course
- seek($message, 0, 0);
- process(\@mimes, $message, boundary => undef);
-
- # everything is done, probably some rest is still unprocessed (some
- # epilogue, but this shouldn't be a problem at all
- {
- local $/ = \10240;
- if ($tmpout) {
- seek($tmpout, 0, 0);
- select $stdout;
- print while <$tmpout>;
- }
- print while <$message>;
- }
-
- exit 0;
-}
-
-sub print_message(*@) {
- my ($m, %arg) = @_;
-
- while (<$m>) {
- print;
- last if $arg{to} and /^--\Q$arg{to}\E/;
- }
-}
-
-sub process($*;@) {
- my ($mimes, $m, %arg) = @_;
- my ($header, %header) = read_header($m);
- my ($type, $boundary);
-
- if ($header{"content-type"}) {
- ($type) = ($header{"content-type"} =~ /^([^;]*)/);
- (undef, $boundary)
- = ($header{"content-type"} =~ /boundary=(['"])(.*?)\1/);
- ### h{content-type}: $header{"content-type"}
- ### type: $type
- ### bound: $boundary
- }
-
- $boundary ||= $arg{boundary};
-
- if (not $type or pass_mime($type, $mimes)) {
- warn "passing: " . ($type ? $type : "no mime type") . "\n";
- print $header;
- print_message($m, to => $boundary);
- return;
- }
-
- if ($type =~ m{^multipart/}) {
- warn "forward to next multipart boundary: $boundary\n";
- print $header;
- print_message($m, to => $boundary);
-
- while (not eof($m)) {
- process($mimes, $m, boundary => $boundary);
- }
-
- return;
- }
-
- warn "removed: $type\n";
-
- my ($eol) = ($header =~ /(\s*)$/);
- $header =~ s/\s*$//;
- $header =~ s/^/-- /gm;
-
- print "Content-Type: text/plain" . $eol x 2
- . "Content removed (" . localtime() . ")$eol"
- . $header
- . $eol;
-
- while (<$m>) {
- if (/^--\Q$boundary\E/) {
- print;
- last;
- }
- }
-
-}
-
-sub pass_mime($$) {
- my ($type, $mimes) = @_;
- local $_ = $type;
- my $re = join "|", map { $a = $_; $a =~ s/([^\da-z])/\\$1/gi; $a } @$mimes;
- return m{$re};
-}
-
-sub read_message() {
- my $tmp = tempfile();
-
- local $/ = \102400;
- print {$tmp} $_ while <>;
- chmod 0400, $tmp or die "Can't fchmod on tmpfile: $!\n";
-
- return $tmp;
-}
-
-# in: current message file handle
-# out: ($orignal_header, %parsed_header)
-sub read_header(*) {
- my ($msg) = @_;
- my $h = "";
-
- while (<$msg>) {
- $h .= $_;
- last if /^\s*$/m;
- }
-
- $_ = $h; # unmodified header (excl. $from)
-
- ### $_
-
- s/\r?\n\s+(?=\S)/ /gm; # continuation lines
- s/^(\S+):/\L$1:/gm; # header fields to lower case
-
- return ($h,
- map { ($a = $_) =~ s/\s*$//; $a }
- ":unix_from:" => split(/^(\S+):\s*/m, $_));
-}
-__END__
-# vim:ts=4