#!/usr/bin/perl -w 
#
# LeechGPOP - zapisuje JEDYNIE zaczniki z poczty POP3, uwzgldnia filtrowanie.
# Cz pakietu Leecharoo - przeznaczonego do obsugi wszystkich trudnych
# do automatycznego pobierania miejsc.
# http://disobey.com/d/code/ lub kontaktuj si z morbus@disobey.com.
#
# Kod ten jest darmowym oprogramowaniem; mona go rozpowszechnia i/lub
# modyfikowa na takich samych warunkach, jak samego Perla.

use strict; $|++;
my $VERSION = "1.0";
use Getopt::Long;
my %opts;

# upewniamy si, e mamy potrzebne moduy; jeli nie, koniec programu.
eval("use Net::POP3;"); die "[err] Brak moduu Net::POP3.\n" if $@;
eval("use MIME::Parser;"); die "[err] Brak moduu MIME::Parser.\n" if $@;

# definiujemy nasz flagi wiersza polece (wersje dugie i krtkie).
GetOptions(\%opts, 'server|s=s',      # uywany serwer POP3.
                   'username|u=s',    # uywane konto POP3.
                   'password|p=s',    # uywane haso POP3.
                   'begin|b=i',       # pocztkowy numer wiadomoci.
);

# potrzebne s przynajmniej dane pozwalajce si zalogowa.
die "[err] Brak serwera POP3, uyj opcji --server lub -s.\n" unless $opts{server};
die "[err] Brak konta, uyj opcji --username lub -u.\n"  unless 
$opts{username};
die "[err] Brak hasa, uyj opcji --password lub -p.\n"  unless 
$opts{password};

# pocztkowa prba poczenia si z serwerem.
print "-" x 76, "\n"; # po prostu separator.
my $conn = Net::POP3->new( $opts{server} )
  or die "[err] Bd czenia si z serwerem.\n";
print "czenie si z serwerem POP3 $opts{server}.\n";

# teraz dane do zalogowania si.
$conn->login( $opts{username}, $opts{password} )
  or die "[err] Nieudane logowanie na serwerze (.blokada? autoryzacja?).\n";
print "Poczono si jako $opts{username}.\n";

# oglne dane o skrzynce pocztowej.
my ($msg_total, $mbox_size) = $conn->popstat(  );
if ($msg_total eq 0)  { print "Brak wiadomoci e-mail.\n"; exit; }
if ($msg_total eq '0E0')  { print "Brak wiadomoci e-mail.\n"; exit; }
print "Razem jest $msg_total wiadomoci na ", commify($mbox_size), "kB.\n";

# lista dopuszczalnych rozszerze plikw. Uywane s rozszerzenia, a nie typy
# MIME, gdy s atwiejsze do zrozumienia dla uytkownika.
my $valid_exts = "jpg jpeg png";
my %msg_ids; # rejestracja sprawdzanych listw.
my $msg_num = $opts{begin} || 1; # wskazany przez uytkownika lub 1.

# utworzenie podkatalogu o nazwie zalenej od daty.
my ($d,$m,$y) = (localtime)[3,4,5]; $y += 1900; $m++;
$d = sprintf "%02.0d", $d; $m = sprintf "%02.0d", $m;
print "Nowe pliki s umieszczane w katalogu '$y-$m-$d'.\n";
my $savedir = "$y-$m-$d"; mkdir($savedir, 0777);


# ptla po wszystkich wiadomociach.
print "-" x 76, "\n"; # po prostu separator.
while ($msg_num <= $msg_total) {

    # wielko poszczeglnych wiadomoci.
    my $msg_size = $conn->list($msg_num);

    # pobierz nagwek wiadomoci, aby 
    # unikn pobierania duplikatw.
    my $headers = $conn->top($msg_num);

    # poka/zapisz podane fragmenty.
    my ($msg_subj, $msg_id);
    foreach my $header (@$headers) {

        # podaj temat i wielko.
        if ($header =~ /^Subject: (.*)/) {
            $msg_subj = substr($1, 0, 50); # ewentualnie skrcenie tematu.
            print "Msg $msg_num / ",commify($msg_size),"k / $msg_subj...\n";
        }

        # zapisz Message-ID, aby sprawdza duplikaty.
        elsif ($header =~ /^Message-ID: <(.*)>/i) {
            $msg_id = $1; $msg_ids{$msg_id}++;
        }

        # przejd do filtrowania.
        elsif ($msg_subj and $msg_id) { last; }

    }

    # jeli wiadomo jest zbyt maa, moe by odpowiedzi lub 
    # obrazkiem niskiej jakoci.
    if (defined($msg_size) and $msg_size < 40000) {
        print "  Pomijam - wiadomo mniejsza od ustalonego minimum.\n";
        $msg_num++; next;
    }

    # Szukanie pasujcych Message-ID. Jeli znaleziono,
    # pomijamy wiadomo. Pomoe to wyeliminowa tzw.
    # crossposting oraz duplikaty.
    if (defined($msg_id) and $msg_ids{$msg_id} >= 2) {
        print "  Pomijam - ten Message-ID ju wystpi.\n";
        $msg_num++; next;
    }

    # pobierz wiadomo, aby przekaza j do MIME::Parser.
    my $msg = $conn->get($msg_num);

    # utwrz obiekt MIME::Parser, aby pobra
    # wszelkie zaczniki.
    my $parser = new MIME::Parser;
    $parser->output_dir( $savedir );
    my $entity = $parser->parse_data($msg);

    # pobieramy poszczeglne czci MIME i kad z nich analizujemy.
    my @parts = $entity->parts;
    foreach my $part (@parts) {

        # okrelenie cieki do badanego pliku.
        my $path = ($part->bodyhandle) ? $part->bodyhandle->path : undef;

        # jeli typ nie jest zdefiniowany, idziemy dalej;
        # w przeciwnym razie odgadujemy rozszerzenie.
        next unless $path; $path =~ /\w+\.([^.]+)$/;
        my $ext = $1; next unless $ext;

        # idziemy dalej tylko wtedy, gdy rozszerzenie jest poprawne.
        my $continue; $continue++ if $valid_exts =~ /$ext/i;

        # usuwamy niepodane elementy.
        unless ($valid_exts =~ /$ext/) {
           print "  Usuwanie niepodanego typu ($ext): $path\n";
           unlink $path or print " > Bd usuwania pliku $path: $!.";
           next; # przejcie do nastpnego zacznika lub wiadomoci.
        }

        # podany typ pliku. Mniam!
        print "  Zapis pliku: $path.\n";
    }

    # Zwikszenie licznika. 
    $msg_num++;
}

# sprztanie, zamknicie poczenia.
$conn->quit;

# teraz przejcie do katalogu i usunicie wszystkich plikw msg-*,
# ktre zawieraj treci wiadomoci zapisywane przez MIME::Parser.
chdir ($savedir); opendir(SAVE, "./") or die $!;
my @dir_files = grep !/^\.\.?$/, readdir(SAVE); closedir(SAVE);
foreach (@dir_files) { unlink if $_ =~ /^msg-/; }

# cookbook 2.17.
sub commify {
    my $text = reverse $_[0];
    $text =~ s/(\d\d\d)(?=\d)(?!\d*\.)/$1,/g;
    return scalar reverse $text;
}

