(as)  [sysadmin] [blog]

User Tools

Site Tools


This is an old revision of the document!


A Perl script to remove attachments from e-mail messages


attachment_filter.pl < message


attachment_filter.pl reads a single email message from STDIN, parses it using Email::MIME and returns the email message at STDOUT. Attachments whose Content-Type do not match the regular expression in $allowed_attachments are replaced with a $replacement_text.


# Script to remove attachments from mail messages using Email::MIME
# All attachments whose Content-Type does not match $allowed_attachments
# are removed and replaced with $replacement_text.
# Version: 1.2 * 2016-06-16 (c) Andreas Schamanek
# This script is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY. Use at your own risk!
# URL https://fam.tuwien.ac.at/~schamane/_/attachment_filter_pl
use strict;
use warnings;
# Email::MIME: http://search.cpan.org/perldoc?Email::MIME
# Debian package libemail-mime-perl
use Email::MIME;
# Regex to match on allowed content-types (case-insensitive)
my $allowed_attachments = "^((text|message)/|application/(pkcs|pgp))";
# Replacement text (must be us-ascii; or change the script)
my $replacement_text = "Attachment removed. Original Content-Type:\n  ";
# Note: Variable $email is only used if $mail_was_modified = 1; so, if we 
# know that attachments are indeed stripped we could do without $email.
# Global Variables
use vars qw(
	$email $email_parsed $first_line
$mail_was_modified = 0;
# Get email from standard input
$first_line = scalar <STDIN>;
# Read in the remainder
$email = join('', <STDIN>);
# Prepend $first_line unless it is a "From ..." line; in which case we 
# preserve it to work around some bugs
$email = $first_line . $email unless ($first_line =~ /^From .*\@/);
# Parse email
$email_parsed = Email::MIME->new($email);
# Debug MIME structure
#print STDERR "(debug) parsed structure:\n".$email_parsed->debug_structure;
# Remove attachments that do not match /$allowed_attachments/i
$email_parsed->walk_parts(sub {
	my ($part) = @_;
	return if $part->subparts; # multipart
	if ($part->content_type && $part->content_type !~ /$allowed_attachments/i)
		# record that the email has been modified
		$mail_was_modified = 1;
		# replacement text
		$part->body_set($replacement_text . $part->content_type."\n");
# replace email with stripped email
if ($mail_was_modified)
	my @parts_new = $email_parsed->parts;
	$email_parsed->parts_set( \@parts_new );
	$email = $email_parsed->as_string;
# output the message
print $first_line if ($first_line =~ /^From .*\@/);
print $email;


I do not know much Perl. Suggestions for improvements are welcome!
Also, I haven't tested this much. Use at your own risk!


See also


attachment_filter_pl.1471880138.txt.gz · Last modified: 2016-08-22 17:35 by andreas