#!/usr/bin/perl -w

use strict;
use Net::SMTP::TLS;
use IMAP::Client;
use Date::Parse;
use MIME::Base64;
use File::Type;
use File::Spec;

my $mailaddr= "yourmail\@provider.bla";
my $imapserver= "imap.provider.bla";
my $imapuser= $mailaddr;
my $imappass= "secret";
my $smtpserver= "smtp.provider.bla";
my $smtpfrom= $mailaddr;
my $smtpuser= $imapuser;
my $smtppass= $imappass;

my %options;

my @optlist= qw(help list retrieve save debug);

sub connect_login
{
  my $cl= IMAP::Client->new($imapserver);
  die "Could not create IMAP client" unless ref($cl);
  $cl->connect(PeerAddr => $imapserver)
  	or die "Could not connect to $imapserver: " . $cl->error();
  $cl->debuglevel($options{"debug"} || 0);
  $cl->errorstyle("LAST");
  $cl->capability_checking(1);
  $cl->login($imapuser, $imappass) or die "Could not log in: " . $cl->error();
  $cl->examine("INBOX") or die "Could not examine INBOX: " . $cl->error();
  return $cl;
}

sub list
{
  my @terms= @_;
  my $set= "1:*";
  my %result;

  my $cl= connect_login();
  if( @terms ) {
    my @messages;
    for my $term (@terms) {
      push @messages, ($cl->search("SUBJECT $term"));
      # There is no error return code for search() in IMAP::Client 0.13
    }
    unless( @messages ) {
      $cl->logout();
      exit;
    }
    $set= join(",", @messages);
  }
  %result= $cl->fetch($set, undef, "ENVELOPE", "RFC822.SIZE");
  for my $msgnum (sort {$a <=> $b} keys(%result)) {
    my $msg= $result{$msgnum};
    print "Subject: ", $msg->{"ENVELOPE"}->{"SUBJECT"}, "\n",
	  "Date: ", $msg->{"ENVELOPE"}->{"DATE"}, "\n",
	  "Size: ", $msg->{"RFC822"}->{"SIZE"}, " octets\n\n";
  }
  $cl->logout();
}

my @monthname= ( "Jan" , "Feb" , "Mar" , "Apr" , "May" , "Jun" ,
                  "Jul" , "Aug" , "Sep" , "Oct" , "Nov" , "Dec" );

sub retrieve
{
  my ($term, @datewords)= @_;
  my $date= join(" ", @datewords);
  my $cl;
  my $msgnum;
  my %result;
  my $data;
  my $name;
  my $mdate;

  if( $date !~ /^(?:newest|oldest)$/ )
  {
    my (undef, undef, undef, $day, $month, $year)= strptime($date);
    die "Could not parse date $date."
	  unless( defined($day) && defined($month) && defined($year) );
    $date= sprintf("%02d-%s-%04d", $day, $monthname[$month], $year+1900);
    $cl= connect_login();
    # This relies on the fact that the server returns earlier messages first,
    # which seems to be true
    ($msgnum)= ($cl->search("SUBJECT $term SENTSINCE $date"));
    unless( $msgnum ) {
      print STDERR "The server could not find any mail containing $term " .
      			"from $date or newer.\n";
      $cl->logout();
      return;
    }
  }
  else {
    $cl= connect_login();
    my @allmsgnums= ($cl->search("SUBJECT $term"));
    unless( @allmsgnums ) {
      print STDERR "The server could not find any mails containing $term.\n";
      $cl->logout();
      return;
    }
    # This relies on the fact that the server returns earlier messages first,
    # which seems to be true
    $msgnum= $date eq "newest"? $allmsgnums[-1] : $allmsgnums[0];
  }
  %result= $cl->fetch($msgnum, { "body" => 2, peek => 1 }, "ENVELOPE");
  $data= $result{$msgnum}->{"BODY"}->{2}->{"BODY"};
  my (undef, undef, undef, $day, $month, $year)=
  			strptime($result{$msgnum}->{"ENVELOPE"}->{"DATE"});
  if( defined($day) && defined($month) && defined($year) ) {
    $mdate= sprintf("%02d-%s-%04d", $day, $monthname[$month], $year+1900);
  }
  else {
    print STDERR "Could not parse mail envelope date.  Using requested date" .
    		" instead.\n";
    $mdate= $date;
  }
  if( $cl->imap_send("FETCH $msgnum BODYSTRUCTURE") && 
    	(my @struct= $cl->imap_receive()) ) {
    $name= $1 if $struct[0] =~ /\"filename\"\s+\"([^"]+)/i;
  }
  $cl->logout();
  if( !$name ) {
    print STDERR "Could not obtain file name from BODYSTRUCTURE.  ",
    		"Using search term instead.\n";
    $name= $term;
  }
  $name .= ".$mdate";
  open OUT, ">$name" or die "Could not open $name for output";
  print OUT MIME::Base64::decode_base64($data);
  close OUT;
}

sub save
{
  my ($name)= @_;
  my $data;
  my $mimet;
  my $bound= "----8<----snip----8<----";

  open IN, "<$name" or die "Could not open $name";
  {
    local $/;
    $data= <IN>;
    die "Could not read $name: $!" unless defined($data);
  }
  close IN;
  (undef, undef, $name)= File::Spec->splitpath($name);
  my $ft= File::Type->new();
  $mimet= $ft->checktype_contents($data);
  my $sm= Net::SMTP::TLS->new($smtpserver, "Debug" => $options{"debug"},
  		"User" => $smtpuser, "Password" => $smtppass )
  	or die "Could not create SMTP object";
  $sm->mail($smtpfrom) or die "Error on MAIL command";
  $sm->to($mailaddr) or die "Error on RCPT TO command";
  $sm->data() or die "Error on DATA command";
  $sm->datasend("From: $smtpfrom\r\nTo: $mailaddr\r\nSubject: $name\r\n" .
		"MIME-Version: 1.0\r\n" .
		"Content-Type: multipart/mixed; boundary=\"$bound\"\r\n");
  $sm->datasend("\r\n--$bound\r\nContent-Type: text/plain\r\n" .
		"Content-Transfer-Encoding: quoted-printable\r\n\r\n" .
		"\r\n\r\n");
  $sm->datasend("--$bound\r\nContent-Type: $mimet; name=\"$name\"\r\n" .
		"Content-Transfer-Encoding: base64\r\n" .
		"Content-Disposition: attachment; filename=\"$name\"\r\n\r\n" .
		MIME::Base64::encode_base64($data) . "--$bound--\r\n");
  $sm->dataend();
  $sm->quit();
}

sub help
{
  print <<EOF
usage: mailbackup [options] <arguments ...>
Available options:
-s, --save	Send a mail to the mailbox with <1st arg> as attachment
		(default operation when no options are given)
-l, --list	List mails containing one of <arguments> in their subject.
		Without argument, lists all.
-r, --retrieve	Retrieves attachment of the message with <1st arg> in the 
		subject which is just younger than the date in <other args>.
		If <other args> is "newest" or "oldest", gets that version.
-d, --debug	Print out conversation with IMAP/SMTP server
See also: http://www.volkerschatz.com/net/mailbak.html
EOF
}

if( @ARGV == 0 ) {
  help();
  exit 0;
}

while( @ARGV && $ARGV[0] =~ s/^-// ) {
  my $opt= shift @ARGV;
  my $existent;
  if( $opt =~ s/^-// ) {
    ($existent)= grep $_ eq $opt, @optlist;
    $opt= "--" . $opt;
  }
  elsif( length($opt) == 1 ) {
    ($existent)= grep substr($_, 0, 1) eq $opt, @optlist;
    $opt= "-" . $opt;
  }
  unless( $existent ) {
    print STDERR "Unknown option $opt.\n";
    help();
    exit 1;
  }
  $options{$existent}= 1;
}

my $totalcmds= ($options{"list"} || 0) + ($options{"retrieve"} || 0) +
		($options{"help"} || 0) + ($options{"save"} || 0);
if( $totalcmds > 1 ) {
  print STDERR "Only one of -l, -r, -s or -h may be given.\n";
  help();
  exit 1;
}

if( $options{"help"} ) {
  help();
  exit 0;
}
elsif( $options{"list"} ) {
  list( @ARGV );
}
elsif( $options{"retrieve"} ) {
  if( @ARGV < 2 ) {
    print STDERR "--retrieve requires a keyword and a date argument.\n";
    help();
    exit 1;
  }
  retrieve(@ARGV);
}
else {
  if( @ARGV != 1 ) {
    print STDERR "--save takes exactly one argument.\n";
    help();
    exit 1;
  }
  save($ARGV[0]);
}