#!/usr/bin/perl
# A checker for e-mail addresses
# Written by Martin Mares <mj@ucw.cz> and put into public domain

# We follow the e-mail address syntax in RFC 2822, but with a couple of exceptions:
# - control characters are not allowed, even if properly escaped
# - we allow dots not only between non-empty atoms, but also as separate atoms
# - some obsolete constructs are not supported
# - at least one dot is required in the domain

sub email_ok($) {
	my $addr = shift @_;
	return ($addr =~
		/^([!#-'*+.-9=?A-Z^-~-]+|"([ !#-\[\]-~]|\\[ -~])*")@([!#-'*+-9=?A-Z^-~-]+\.[!#-'*+.-9=?A-Z^-~-]+|\[([ -Z^-~]|\\[ -~])+(\.|\\\.)([ -Z^-~]|\\[ -~])+\])$/
	) ? 1 : 0;
}

my @tests = (
	'a.b.c.d' => 0,			# no @
	'a@b' => 0,			# no dot in domain
	'a@b.c' => 1,			# ok
	'a@b@c.d' => 0,			# multiple @'s
	'"a@b"@c.d' => 1,		# but ok in quotes
	'a b@c.d' => 0,			# spaces not permitted
	'"a b"@c.d' => 1,		# but again they are ok when quoted
	'"x y"z@c.d' => 0,		# quoting must not be partial
	'""@c.d' => 1,			# strange, but correct
	'!#$%&*+-/=?^_`{}|@c.d' => 1,	# all sorts of perrmited weird chars
	'"a \"\\@\@"@c.d' => 1,		# backslash escapes
	'"\"@c.d' => 0,			# misquoted
	'...@c.d' => 1,			# RFC disallows this, but generally accepted
	'baba@a b.cz' => 0,		# no spaces in domain
	'ganesha@a.' => 0,		# dot here is not enough
	'ganesha@a.b.' => 1,		# but trailing dots are ok, although not canonical
	'odin@[1.2.3.4]' => 1,		# numeric address
	'odin@1.2.3.4' => 1,		# correct, although probably undeliverable
	'odin@[valhalla . gov]' => 1,	# spaces allowed here
	'odin@[val\[halla\].\\gov]' => 1,  # escapes as well
	'odin@[val\]' => 0,		# but we must not forget to close ]
	'odin@[abc].def' => 0,		# mixed is invalid
	'"@"@[@.@]' => 1,		# wow!
	'[@.@]@[@.@]' => 0,		# but this is not OK (unquoted "[")
	'a@a..b' => 1,			# undeliverable, but syntactically OK
);

print "Testing:\n";
while (@tests) {
	my $addr = shift @tests;
	my $res = email_ok($addr);
	print "$addr: $res\n";
	$res == shift @tests or die "Test failed";
}
print "All tests passed.\n\nTry yourself:\n";
while (<>) {
	chomp;
	print email_ok($_), "\n";
}