#!/usr/bin/env perl

 use strict;

 use MIME::Parser;

 use Net::SMTP;

 # K doručenkám typu:

 #	Content-Type: multipart/report; report-type=delivery-status; ~ Delivery Status Notification (DSN)

 # doplňujeme hlavičku References, 

 # aby si je e-mailový klient mohl zařadit do vlákna pod zprávu, ke které doručenka patří.

 # viz http://search.cpan.org/~dskoll/MIME-tools-5.502/lib/MIME/Entity.pm

 # viz http://search.cpan.org/~dskoll/MIME-tools-5.502/lib/MIME/Head.pm

 # viz http://perldoc.perl.org/Net/SMTP.html

 # aptitude install libmime-tools-perl libmailtools-perl

 # Nastavení --------------------------------------------------------------------

 my $komu = 'noreply@example.com'; # adresa správce – sem pošleme zprávy, pokud nevíme, kam je poslat (chybí Delivered-To), nebo máme podezření na zacyklení

 # ------------------------------------------------------------------------------

 my $znacka = "X-DSN-Pridej-References"; # hlavička, kterou si poznačíme, že zpráva prošla tímto programem

 my $stav = "chyba - nedefinovano"; # výchozí hodnota naší hlavičky

 # Načteme zprávu

 my $parser = new MIME::Parser;

 $parser->output_to_core(1);

 my $dorucenka = $parser->parse(\*STDIN);

 # Kontrola, že se zpráva nezacyklila (chybí naše značka)

 if ($dorucenka->head->count($znacka) == 0) {

 	# Podle hlavičky Delivered-To zjistíme, kam máme zprávu poslat zpátky	

 	my $deliveredTo = $dorucenka->head->get("Delivered-To", 1); # [0] = adresa tohoto skriptu, [1] = předchozí adresa – původní příjemce doručenky 

 	if ($deliveredTo) {

 		$deliveredTo =~ s/\s+$//; # zbavíme se přebytečného konce řádku

 		$komu = $deliveredTo;

 		$dorucenka->head->delete("Delivered-To", 1); # aby si poštovní server nemyslel, že se zpráva zacyklila 

 		# Pokud hlavička References chybí, doplníme ji

 		if ($dorucenka->head->count("References") == 0) {

 			# Zjistíme Message-ID původní zprávy

 			my $messageID;

 			my @casti = $dorucenka->parts;

 			for my $cast (@casti) {

 				if ($cast->mime_type eq "text/rfc822-headers") {

 					my @radky = $cast->bodyhandle->as_lines;

 					for my $radek (@radky) {

 						if ($radek =~ /^Message-ID:\s*(<.*>)$/) {

 							$messageID = $1;

 						}

 					}

 				}			

 			}		

 			# Nastavíme nalezené Message-ID do References hlavičky

 			if ($messageID) {

 				$stav = "ok";

 				$dorucenka->head->add("References", $messageID);

 			} else {

 				$stav = "chyba - Message-ID nenalezeno";

 			}

 		} else {

 			$stav = "ok - hlavicka References uz byla nastavena drive";

 		}		

 	} else {

 		$stav = "chyba - nevime, kam zpravu poslat zpet";

 	}	

 } else {

 	$stav = "chyba - zprava se zacyklila";

 }

 $stav .= " [pid=$$,uid=$>]"; # přidáme PID a UID

 $dorucenka->head->add($znacka, $stav);

 # Výpis (nepotřebujeme, jen pro ladění)

 #$dorucenka->print(\*STDOUT);

 #print "Pošleme komu: $komu\n";

 # Odeslání přes SMTP (pro ostrý provoz):

 my $smtp = Net::SMTP->new("localhost");

 $smtp->mail('<>');

 $smtp->to($komu);

 $smtp->data();

 $dorucenka->print($smtp);

 $smtp->dataend();

 $smtp->quit;