mutt-trim

#!/usr/bin/perl
#
# Remove any clutter from the quoted message.
# Originally named autotrim and written by Michael Velten.

use utf8;

# keep nested quotes up to $ind_max-th level
my $ind_max = 5;
# insert $gap many blank lines between different quote levels
my $gap = 0;

my $name     = '[[:alpha:]]+([\'`-][[:alpha:]]+|[.])*';
my $fullname = '\b(' . $name . '[,]?\s+)*' . $name . '\b';

# Possible reply greetings (regexes) (note that '> ' will be prefixed)
my @greetings = (
  'Dear',
  '[Hh](ello|i|ey)',
  '[Gg]ood ([Mm]orning|[Aa]fternoon|[Ee]vening)',
  'Sehr geehrter?',
  'Lieber?',
  'Guten (Tag|Morgen|Nachmittag|Abend)',
  '[Hh]allo',
  '[Mm]oin',
  '[Mm]esdames(,| et) [Mm]essieurs\s*[,.!]?',
  'M(adame)',
  'M(onsieur)',
  '[Cc]her',
  '[Cc]h[eè]re',
  '[Bb]onjour',
  '[Ss]alut',
  'Senhor(ita|a)?',
  'Sra?\.?',
  'Car([ií]ssim)?[ao]s?',
  'Prezad([ií]ssim)?[ao]s?',
  'Estimad([ií]ssim)?[ao]s?',
  '[Bb]om [Dd]ia',
  '[Bb]oa ([Tt]arde|[Nn]oite)',
  '[Oo](i|l[aá])',
  '[Aa]l[ôo]',
  '[Hh]ola',
  'Se[nñ]or(ita|a)?',
);

# Possible reply "greetouts" (regexes) (note that '> ' will be prefixed)
my @greetouts = (
  '([Ww]ith )?(([Kk]ind|[Bb]est|[Ww]arm) )?([Rr]egards|[Ww]ishes)',
  '[Bb]est',
  '[Cc]heers',
  '([Mm]any\s+)?[Tt]hanks',
  '[Mm]it ([Vv]iel|[Bb]est|[Ll]ieb|[Ff]reundlich|[Hh]erzlich)en [Gg]r([ü]|ue)([ß]|ss)en',
  '(([Vv]iel|[Bb]est|[Ll]ieb|[Ff]reundlich|[Hh]erzlich)e )?[Gg]r([ü]|ue)([ß]|ss)e',
  '(([[Bb]est|[Ll]ieb|[Ff]reundlich|[Hh]erzlich)e[rn] )?[Gg]ru([ß]|ss)',
  '[Mm]it (([[Bb]est|[Ll]ieb|[Ff]reundlich|[Hh]erzlich)em )?[Gg]ru([ß]|ss)',
  '([LV]|MF)G',
  '(([Tt]r[eè]s|[Bb]ien) )?([Cc]ordi|[Aa]mic)alement',
  '[Aa]miti[eé]s?',
  '[Aa]tenciosamente',
  '[Aa]tt',
  '[Aa]bra[cç]os?',
  '[Aa]tentamente',
  '[Cc]ordialmente',
);

my $word = '[[:alpha:]]+([\'`-][[:alpha:]]+)*';

# my $saw_greeting = 0;
# my $saw_greetout = 0;
my $saw_blank_line = 0;
my $prev_inds = 0;
my $saw_own_sig = 0;
my $inds_other_sig = 0;
my $quote_header = 0;
my $extra_pref = '';

my (@mail, @purged_mail);

my $msg = shift;
die "Usage: $0 MAIL" unless $msg;
open(MAIL, "+<:encoding(UTF-8)", $msg)  or die "$0: Can't open $msg: $!";
push(@mail, $_) while <MAIL>;   # Read whole mail

# Process whole mail
LINE:
foreach my $line (@mail) {

  my $inds = 0;
  # count indent level
  if ($line =~ /^>/) {
    # $line =~ tr/\xA0/ /;
    # tighten "> > " to ">> "
    my ($pref, $suff) = $line =~ /^([>[:space:]]+)(.*)$/;
    $pref =~ s/(>\s*(?!$))/>/g;

    # reduce multiple pre- and post-blanks to one post-blank
    $pref =~ s/^\s*(>+)\s*/$1 /;
    $line = $pref . $suff . "\n";

    # prepend additional '>' for each Outlook quote header
    if ($line =~ /^>+ [-_=━]{3,}\s*($word)?(\s+$word)*\s*[-_=━]{3,}$/) {
      $quote_header = 1;
      next LINE;
    }
    # first line after Outlook quote header that does not start with ...:
    if ($quote_header == 1 && $line !~ /^>+ ([-*]\s*)?$word(\s+$word)*\s*:\s+/) {
      $extra_pref = '>' . $extra_pref;
      $quote_header = 0;
    }
    $pref = $extra_pref . $pref;
    $line = $pref . $suff . "\n";
    $inds = $pref =~ tr/>//;
  }

  # remove last line if blank and last in citation level
  if ($inds == 0 && $inds < $prev_inds && $saw_blank_line) {
    $prev_inds = $inds;
    pop @purged_mail;
  }

  # Treat non-quoted lines as is
  if ($inds == 0) {
    push(@purged_mail, $line);
    next LINE;
  }

  # Keep all lines after my own signature unmodified
  if ($line =~ /^--\s?$/ || $saw_own_sig) {
    $saw_own_sig = 1;
    push(@purged_mail, $line);
    next LINE;
  }

  # skip line if number of '>'s is greater than $ind_max
  if ($inds > $ind_max) {
    next LINE;
  }

  # Remove other signatures
  if ($line =~ /^>+ --\s?$/) {
    $inds_other_sig = $inds;
  }
  if ($inds == $inds_other_sig) {
    next LINE;
  } else {
    $inds_other_sig = 0;
  }

  # Remove quoted greeting
  # unless ($saw_greeting) {
  foreach my $greeting (@greetings) {
    $greeting = '\s*' . $greeting . '(\s+' . $fullname . ')?' . '(\s*[,.!]+)?' . '\s*';
    if ($line =~ /^>+ $greeting$/) {
      # $saw_greeting = 1;
      next LINE;
    }
  }
  # }

  # Remove quoted "greetout"
  # unless ($saw_greetout) {
  foreach my $greetout (@greetouts) {
    $greetout = '\s*' . $greetout . '(\s*[,.!]+)?' . '\s*';
    if ($line =~ /^>+ $greetout$/) {
      # $saw_greetout = 1;
      next LINE;
    }
  }
  # }

  # Remove quoted filler lines
  if ($line =~ /^>+ \s*[-_=+#*]+$/) {
    next LINE;
  }

  # Squeeze multiple blank lines
  if ($line =~ /^>+\s*$/){
    if ($saw_blank_line) {
      next LINE;
    } else {
      $saw_blank_line = 1;
      # remove trailing blanks
      $line =~ tr/ //ds;
    }
  } else {
    $saw_blank_line = 0
  }

  # Insert $gap many empty lines between different quote levels
  $line = "\n" x $gap . $line if $prev_inds != $inds;

  $prev_inds = $inds ;

  # Save purged line
  push(@purged_mail, $line);
}

# Overwrite original mail with purged mail
truncate(MAIL, 0);
seek(MAIL, 0, 0);
print MAIL @purged_mail;
close(MAIL);