procmail2sieve.pl

#!/usr/local/bin/perl
#
# usage: procmail2sieve <path to .procmailrc>
#
# A simple procmailrc (including piping into vacation) to Sieve conversion script.
#
# This version can handle simple matches (with regex), acting on a copy or inline,
# sending to a folder, redirection and piping into vacation. It can't handle nested
# match rules or anything very complex.
#
# The script will filter the given .procmailrc and, if required, look in the same
# directory for a .vacation.msg file and output the Sieve equivalent to standard output.
#
# Note: This will only work with Sieve interpretors with implement the regex, envelope and
#       vacation extensions, e.g. the Dovecot-Sieve plugin.
#

$domain="my.mail.domain.com";

die("usage: $0 procmailrc\n") if (scalar(@ARGV) == 0);

$filename = $ARGV[0];

@filepath = split('/', $filename);
$#filepath = $#filepath - 1;

$homedir = '/'.join('/', @filepath);

open(PROCMAILRC, "<$filename") || die("Can't open $filename\n");

$copy = 0;
$valid = 0;
$filed = 0;

print "# Sieve Filter\n\nrequire [\"fileinto\",\"regex\",\"envelope\",\"vacation\"];\n\n"; 

while(<PROCMAILRC>)
{
	chomp;

# Junk comment lines and empty lines.	
	next if (/^#/);
	next if (/^\s*$/);

# Is it the start of a recipe?
	if (/^:0/)
	{
# If we have previously been processing a recipe finish it off and output the converted version.
		if (($#matches >= 0) && ($valid > 0))
		{
			print join("\n", @matches), "\n";
			if (scalar(@actions) >= 0)
			{
				print "\t", join(";\n\t", @actions), ";\n";

				print "\tdiscard;\n" if (($copy == 0) && ($filed == 0));
				print "}\n\n";
			}
			$filed = 0;
		}
# Determine if we are to be acting on a copy of the message.
		if (/c/)
		{
			$copy = 1;
		}
		else
		{
			$copy = 0;
		}
# Clear out all the matches and actions from the previous recipe.
		@matches = ();
		@actions = ();
		next;
	}

# Is it a match line?
	if (/^\*/)
	{
		$valid++;
		$regex = 0;
		$test = 'if';

		@match = split;
		shift @match;

# Extract the header name from the rest of the line.
		$headername = shift @match;
		$match = join(' ', @match);

# Is the extracted term really a header? If not, assume it's a an unconditional recipe.
		$header = (($headername =~ /\^/)? 1 : 0);
		$headername =~ s/\^//;
# Is it in the envelope or the body?
		if ($headername =~ /:/)
		{
			$header = 2;
			$headername =~ s/://;
		}
# Do we have a regex on our hands?
		if ($match =~ /[\[\(\*\.]/)
		{
			$regex = 1;
			$match =~ s/\\/\\\\/g;
		}

		if ($header)
		{
			if ($header == 1)
			{
				$test = "$test envelope ".($regex ? ':regex ' : '');
			}
			else
			{
				$test = "$test header ".($regex ? ':regex ' : '');
			}
			$matches[scalar(@matches)] = $test.':comparator "i;octet" '.($regex ? '' : ':contains').' "'.$headername.'" "'.$match.'" {';
		}
		else
		{
			$matches[scalar(@matches)] = 'if true {';
		}
		$filed = 1;
		next;
	}

# Is it a redirection?
	if (/^!/)
	{
		$valid++;
		@forward = split;
		shift @forward;
		$actions[scalar(@actions)] = "redirect \"".join(' ', @forward)."\"";
		next;
	}

# Is it a pipe?
	if (/^\|/)
	{
		$valid = 0;

# We can only handle vacation.
		if ((/vacation/) && ( -e "$homedir/.vacation.msg" ))
		{
			@vacargs = split;

# Pare down the line until all we have are the arguments passed to vacation.
			while(!(($i = shift(@vacargs)) =~ /vacation/)){}

# Parse the arguments.
			while ($i = shift(@vacargs))
			{
				if ($i =~ /-a/)
				{
					$i = shift(@vacargs);
					$i =~ s/\"//g;
				}

				$vacaddrs[scalar(@vacaddrs)] = "\"$i\@$domain\"";
			}

# If .vacation.msg doesn't exist then what's the point?
			next if (! open(VACMSG, "<$homedir/.vacation.msg"));

			$vacsubj = '';

# Parse the message, extracting the "Subject:" header as Sieve's vacation uses an
# argument for this part.
			while($msgline = <VACMSG>)
			{
				if ($msgline =~ /^[a-zA-Z-]+:/)
				{
					if ($msgline =~ /^Subject/)
					{
						($junk, $vacsubj) = split(': ', $msgline);
					}
					chomp($vacsubj);
				}
				else
				{
					$vacmess = join('', $vacmess, $msgline);
				}
			}

			close(VACMSG);

# Sieve's vacation is a strange beast, we have to generate it as a match rather than an action.
			$matches[scalar(@matches)] = join(' ', 'vacation', ':days 10', ':addresses', '['.join(',', @vacaddrs).']', ((length($vacsubj) > 0) ? ":subject \"$vacsubj\"" : ''), "\"$vacmess\";");

			$filed = 0 if ($copy == 0);
			$valid++;
		}
		next;
	}

# Now we parse destination folder addresses..

# Strip out any folder prefixes.
	s?Mail/??;

# A special case for /dev/null as this becomes a discard line, otherwise save to a file.
	if (/\/dev\/null/)
	{
		$actions[scalar(@actions)] = "discard";
	}
	else
	{
		$actions[scalar(@actions)] = 'fileinto "'.$_.'"';
	}
}

# By the time we get here we've got a dangling recipe which we need to flush...

if ($valid > 0)
{
	print join("\n", @matches), "\n" if ($#matches >= 0);

	if (scalar(@actions) >= 0)
	{
		print "\t", join(";\n\t", @actions), ";\n" if ($#actions >= 0);

		print "\tdiscard;\n" if (($copy == 0) && ($filed == 0));
		print "}\n\n";
	}
}