#!/usr/bin/perl -wT
use strict;
use lib './lib';
#
# 01.04.2000 - Mikolaj Rydzewski <miki@ceti.pl>
#
# na wejsciu dostanie calego maila - wypluje tylko goly tekst do przeslania
# na komorke
#
# 17.10.2000
#
# zgodnie z sugestia Wiktora program obcina tez sygnaturki - rozpoznaje je
# wg wyrazenia regularnego /^-- $/
#
#
# 18.09.2001 - Radosław Zieliński <radek@karnet.pl>
#
# Przystosowanie do `use strict' i `-T', dekodowanie treści, kosmetyka.
#
# 25.09.2001 - Radosław Zieliński <radek@karnet.pl>
#
# Informacja o kodowaniu może być zapisana także w nagłówkach poszczególnych
# części MIME.  Uwzględniłem...
#

$ENV{PATH} = '/bin:/usr/bin:/usr/local/bin';
delete $ENV{ENV};


my $parse_html = "/usr/bin/lynx -dump -nolist -force_html";
my $mktemp     = "/bin/mktemp /tmp/.show.XXXXXX";
my $bad_text   = qr/(?:^>|^This is a multi-part message in MIME format.{0,2}$|wrote:\s*$|napisa.{1,5}:\s*$)/;

# maksymalna liczba linii do wczytania
my $max_lines = 10;

# 0 - start
##1 - szukanie definicji typu        [wywaliłem to, jest zbędne. --RZ]
# 2 - idziemy do jednej pustej linii
# 3 - body maila
my $stan = 0;

# Content-Type
# 0 - text/plain
# 1 - text/html
my $type = 0;

# Content-Transfer-Encoding
# 0 - [78]bit lub inne "nic szczególnego"
# 1 - quoted-printable
# 2 - base64
my $enc = 0;

my($boundary, @body);


# najpierw szukamy naglowka Content-Type

hdr: {
    my $hdr = '';
    my $koniec;

    while (<STDIN>) {
        chomp;
        $koniec++ unless length;

        if (! length $hdr && ! $koniec) {
            $hdr = $_;
            next;
        }
        if (! $koniec && /^\s+(.+)/) {
            $hdr .= " $1";      # łączenie połamanych nagłówków
        } else {                # przetwarzamy poprzedni nagłówek
            if ($hdr =~ /^Content-Type:.*multipart.*boundary=(["'])([^\1]+)\1/i ) {
                    $boundary = $2;
            }

            $enc = 1 if $hdr =~ /^Content-Transfer-Encoding:.*quoted-printable/i;
            $enc = 2 if $hdr =~ /^Content-Transfer-Encoding:.*base64/i;

            $type = 1 if $hdr =~ /^Content-Type:.*html/i;
            last if $koniec;
            $hdr = $_;
        }
    }
}


if ($boundary) { # sa jakies smieci MIME - wyszukujemy odpowiednie fragmenty
    my $parthead = '';      # tu trzymam nagłówki poszczególnych części MIME
    while (<STDIN>) {
        chomp;
        if      (/^--\Q$boundary/) {
            last if $stan == 3;
            $stan = 2;                          # początek nagłówka części MIME
        } elsif ($stan == 2 &&   length) {
            $parthead .= "$_\n";
        } elsif ($stan == 2 && ! length) {      # ...koniec
            $stan = 3;
            $parthead =~ s/\n\s+/\n /g;         # łączenie pól nagłówka
            $parthead =~ s/^\s+|\s+$//g;
            foreach (split "\n", $parthead) {   # ...i ich analiza
                if    (/^Content-Type:.*html/i)                          { $type = 1 }
                elsif (/^Content-Type:.*text\/plain/i)                   { $type = 0 }
                elsif (/^Content-Transfer-Encoding:.*8bit/i)             { $enc = 0  }
                elsif (/^Content-Transfer-Encoding:.*quoted-printable/i) { $enc = 1  }
                elsif (/^Content-Transfer-Encoding:.*base64/i)           { $enc = 2  }
            }
            $parthead = '';  # żeby się nie gryzły przy następnej części
        } elsif ($stan == 3 && ! /$bad_text/i) {
            last if $#body >= $max_lines;
            push @body, $_;
        }
    }
} else {
    # nie ma multipartow - pokazujemy wszystko jak leci
    while (<STDIN>) {
        chomp;
        last if ($#body > $max_lines || /^-- $/);
#       print "push `$_'\n";
        push(@body, $_) unless /$bad_text/i;
    }
}

my $msg = join "\n", @body;


# jesli wiadomosc jest w HTMLu i trzeba ja sparsowac
if ($type == 1) {
    # To nie jest zbyt bezpieczne...  Do generowania
    # pliku tymczasowego lepiej użyć File::Temp.
    my $fn = `$mktemp`  or die "mktemp: $!";
    open  FILE, "> $fn" or die "wopen  $fn: $!";
    print FILE $msg;
    close FILE          or die "wclose $fn: $!";

    # require File::Temp;
    # my($fh, $fn) = File::Temp::tempfile();
    # print $fh $msg;
    # close $fh             or die "wclose $fn: $!";

    $msg = `$parse_html $fn`;
    unlink $fn;
}


# Dekodowanie maili zakodowanych w QP i Base64.  Nie testowałem, ale nie
# powinno być problemów.  Funkcje decode_qp i old_decode_base64 wyciągnąłem
# z modułów MIME::QuotedPrint i MIME::Base64, żeby program ich nie wymagał.
# Jeśli to możliwe, zalecam użycie samych modułów w ten sposób:
#   if ($enc == 1) {
#           require MIME::QuotedPrint;
#           $msg = MIME::QuotedPrint::decode_qp($msg);
#   } elsif ($enc == 2) {
#           require MIME::Base64;
#           $msg = MIME::Base64::decode_base64($msg);
#   }
# W przypadku Base64 poprawa prędkości będzie znaczna.

if ($enc == 1) {
    $msg = decode_qp($msg);
} elsif ($enc == 2) {
    $msg = old_decode_base64($msg);
}

sub decode_qp {
    my $res = shift;
    $res =~ s/[ \t]+?(\r?\n)/$1/g;  # rule #3 (trailing space must be deleted)
    $res =~ s/=\r?\n//g;            # rule #5 (soft line breaks)
    $res =~ s/=([\da-fA-F]{2})/pack("C", hex($1))/ge;
    $res;
}

sub old_decode_base64 {
    local($^W) = 0; # unpack("u",...) gives bogus warning in 5.00[123]

    my $str = shift;
    my $res = "";

    $str =~ tr|A-Za-z0-9+=/||cd;            # remove non-base64 chars
#   if (length($str) % 4) {
#       require Carp;
#       Carp::carp("Length of base64 data not a multiple of 4")
#   }
    $str =~ s/=+$//;                        # remove padding
    $str =~ tr|A-Za-z0-9+/| -_|;            # convert to uuencoded format
    while ($str =~ /(.{1,60})/gs) {
        my $len = chr(32 + length($1)*3/4); # compute length byte
        $res .= unpack("u", $len . $1 );    # uudecode
    }
    $res;
}



# to ponizej usunie znaki nowej linii i wielokrotne spacje - ale niech bedzie
# mozna uzywac i bez tego
$msg =~ s/^\s+|\s+$//g;             # \s z przodu i z tyłu
$msg =~ y/\x09\x0a\x0d\x20/   /s;   # zamiana \s na spacje i zbijanie

$msg =~ tr/\245\214\217\271\234\237/\241\246\254\261\266\274/; # cp na iso, na wszelki wypadek
$msg =~ y/ęóąśłżźćńĘÓĄŚŁŻŹĆŃ/eoaslzzcnEOASLZZCN/;              # wycinanie polskich znaków

$msg ||= " ";   # zdarza się, że wiadomość jest pusta.

print $msg;

#EOF
