diff -r 9482d3366306 -r 0e1c0994309a hs12 --- 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