Re: How to remove attachments from many mails on Cyrus-IMAP Store?

#!/usr/bin/perl -cw
package MIME::StripAttachments;

use strict;
use warnings;

# Avoid UTF-8 regexp issues. Treat everything as pure
#  binary data
no utf8;
use bytes;

sub StripAttachments {
  my $infh = shift;
  my $outfh = shift;
  my @parts = @_;

  my %todel = map { $_ => 1 } @parts;

  Process($infh, $outfh, sub {
    my $part = shift;
    my $headers = shift;
    return $todel{$part} ? 'delete' : 'keep';
  });
}

sub Process {
  my $infh = shift;
  my $outfh = shift;
  my $decider = shift;

  # Main processing loop
  my $InHeader = 1;
  my $HeadBuffer = '';
  my @Boundaries;
  my @nums;
  my $delbytes = 0;
  my $current_part = '';
  my %HeaderMap;
  my $deleting = 0;
  my $stripped = 0;
  my $deldepth;
  my $deltype;
  my $deldispos;

  while (my $line = $infh->getline()) {
    # Processing a header
    if ($InHeader) {
      $HeadBuffer .= $line;

      # End of headers
      if ($line =~ m/^\r*\n$/) {
        $HeaderMap{$current_part} ||= {};
        $InHeader = ProcessHeaders(\$HeadBuffer, \@Boundaries, $HeaderMap{$current_part});
        unless ($deleting) {
          my ($res, $type) = $decider->($current_part, $HeaderMap{$current_part});
          if ($res eq 'delete') {
            $deleting = 1;
            $delbytes = 0;
            $deldepth = $#Boundaries;
            $deltype = $type || 'x-me-removed';
            $deldispos = $HeaderMap{$current_part}{'content-disposition'}[2];
          }
          elsif ($res eq 'keep') {
            $outfh->print($HeadBuffer);
          } else {
            die "Odd response $res";
          }
        }
        $HeadBuffer = '';
      }
    }

    # In 'body' type section
    else {
      # Found boundary string?
      if (@Boundaries && $line =~ $Boundaries[-1]->[1]) {
        my $Tail = $1;
        if ($deleting) {
          if ($#Boundaries == $deldepth) {
            # we're replacing this one
            $outfh->print("Content-Type: text/$deltype; charset=\"us-ascii\"\r\n");
            $outfh->print("Content-Disposition: $deldispos\r\n") if $deldispos;
            $outfh->print("\r\n");
            $outfh->print("Removed an attachment of $delbytes bytes with the following headers:\r\n");
            foreach my $hn (sort keys %{$HeaderMap{$current_part}}) {
              $outfh->print(join('', @{$HeaderMap{$current_part}{$hn}}) . "\r\n");
            }
            $stripped++;
            $deleting = 0;
          }
          else {
            $delbytes += length($line);
          }
        }
        # Use previous boundary match
        if ($Tail) {
          pop @Boundaries;
        }
        else {
          $nums[$#Boundaries]++;
          $InHeader = 1;
        }
        $#nums = $#Boundaries;
        my @list = @nums;
        $current_part = join('.', @list);
        $outfh->print($line) unless $deleting;
      }
      else {
        if ($deleting) {
          $delbytes += length($line);
        } else {
          $outfh->print($line);
        }
      }
    }
  }

  return $stripped;
}
  
sub ProcessHeaders {
  my ($HeadBuffer, $Boundaries, $HeaderMap) = @_;

  my $rc = 0;

  # Loop through and list all headers (minus \r\n)
  my @Headers;
  pos($$HeadBuffer) = 0;
  while ($$HeadBuffer =~ m/\G([^\s:]+)(:[ \t]*)([^\r\n]*(?:\r?\n[ \t]+[^\r\n]*)*)\r?\n/gc) {
    push @Headers, [ $1, $2, $3 ]
  }
  my ($Remainder) = $$HeadBuffer =~ m/\G(.*)$/s;

  # Build map (prefer earlier headers). Save refs
  my %Headers = map { lc($_->[0]) => $_ } reverse @Headers;

  # Extract new MIME boundary details in content-type headers
  if (my $ContentType = $Headers{'content-type'}) {
    HandleContentTypeHeader($Boundaries, $ContentType->[2]);

    # Return true if message/rfc822 attachment
    if ($ContentType->[2] =~ m{^message/rfc822}i) {
      # We're inside a message now
      $Boundaries->[-1]->[2]++ if @$Boundaries;
      $rc = 1;
    }
  }

  %$HeaderMap = %Headers;

  return $rc;
}

sub HandleContentTypeHeader {
  my ($Boundaries, $HeaderValue) = @_;

  # Put current mime type string into boundary details
  my ($MimeType) = $HeaderValue =~ /^([^;\s]+)/;
  $Boundaries->[-1]->[4] = $MimeType if @$Boundaries;

  # Get boundary string - first try quoted
  my ($Boundary) = ($HeaderValue =~ /boundary="([^"]+)"/i);
  unless ($Boundary) {
    # fall back to pretty restricted
    ($Boundary) = ($HeaderValue =~ /boundary=([^\s;]+)/i);
  }
  return unless $Boundary;

  # Skip boundary if not a multipart/* content type
  return if $MimeType !~ m{^multipart/}i;

  $Boundary = "--" . quotemeta($Boundary);

  # Track how deep we are in attached messages
  my $MessageDepth = @$Boundaries ? $Boundaries->[-1]->[2] : 0;

  # Create match regexp
  push @$Boundaries, [ $Boundary, qr/^$Boundary(--)?\s*$/, $MessageDepth, $MimeType, '' ];
}

1;