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;

# Precompile regex patterns
my $name_regex     = qr/[[:alpha:]]+(?:[\'`-][[:alpha:]]+|[.])*/;
my $fullname_regex = qr/\b(?:$name_regex[, ]?\s+)*$name_regex\b/;
my $word_regex     = qr/[[:alpha:]]+(?:[\'`-][[:alpha:]]+)*/;

my @greetings_regexes = map { qr/$_/ } (
  '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)?',
);

my @greetouts_regexes = map { qr/$_/ } (
  '([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 @greeting_line_regexes = map {
  my $re = $_;
  qr/^>+\s*$re(?:\s+$fullname_regex)?\s*[,.!]*\s*$/
} @greetings_regexes;

my @greetout_line_regexes = map {
  my $re = $_;
  qr/^>+\s*$re(?:\s*[,.!]+)?\s*$/
} @greetouts_regexes;

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 defined $msg && length $msg;
open(my $MAIL, "+<:encoding(UTF-8)", $msg)  or die "$0: Can't open $msg: $!";
push(@mail, $_) while <$MAIL>;

# Precompile regex patterns outside the loop
my $quote_header_regex = qr/^>+\s*[-_=━]{3,}\s*(?:$word_regex(?:\s+$word_regex)*)?\s*[-_=━]{3,}$/;
my $outlook_header_kv_regex = qr/^>+\s*(?:[-*]\s*)?$word_regex(?:\s+$word_regex)*\s*:\s+/;
my $signature_regex = qr/^--\s?$/;
my $other_signature_regex = qr/^>+\s*--\s?$/;
my $filler_line_regex = qr/^>+\s*[-_=+#*]+$/;
my $blank_line_regex = qr/^>+\s*$/;

# 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 =~ $quote_header_regex) {
      $quote_header = 1;
      next LINE;
    }
    # first line after Outlook quote header that does not start with ...:
    if ($quote_header == 1 && $line !~ $outlook_header_kv_regex) {
      $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 =~ $signature_regex || $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 =~ $other_signature_regex) {
    $inds_other_sig = $inds;
    next LINE;
  }
  if ($inds == $inds_other_sig) {
    next LINE;
  } else {
    $inds_other_sig = 0;
  }

  # Remove quoted greeting
  unless ($saw_greeting) {
    foreach my $greeting_re (@greeting_line_regexes) {
      if ($line =~ $greeting_re) {
        $saw_greeting = 1;
        next LINE;
      }
    }
  }

  # Remove quoted "greetout"
  unless ($saw_greetout) {
    foreach my $greetout_re (@greetout_line_regexes) {
      if ($line =~ $greetout_re) {
        $saw_greetout = 1;
        next LINE;
      }
    }
  }

  # Remove quoted filler lines
  if ($line =~ $filler_line_regex) {
    next LINE;
  }

  # Squeeze multiple blank lines
  if ($line =~ $blank_line_regex) {
    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) or die "$0: truncate failed for $msg: $!";
seek($MAIL, 0, 0) or die "$0: seek failed for $msg: $!";
print {$MAIL} @purged_mail;
close($MAIL) or die "$0: close failed for $msg: $!";