checkaddr.pl

   1 #!/usr/bin/perl
   2 # A checker for e-mail addresses
   3 # Written by Martin Mares <mj@ucw.cz> and put into public domain
   4
   5 # We follow the e-mail address syntax in RFC 2822, but with a couple of exceptions:
   6 # - control characters are not allowed, even if properly escaped
   7 # - we allow dots not only between non-empty atoms, but also as separate atoms
   8 # - some obsolete constructs are not supported
   9 # - at least one dot is required in the domain
  10
  11 sub email_ok($) {
  12         my $addr = shift @_;
  13         return ($addr =~
  14                 /^([!#-'*+.-9=?A-Z^-~-]+|"([ !#-\[\]-~]|\\[ -~])*")@([!#-'*+-9=?A-Z^-~-]+\.[!#-'*+.-9=?A-Z^-~-]+|\[([ -Z^-~]|\\[ -~])+(\.|\\\.)([ -Z^-~]|\\[ -~])+\])$/
  15         ) ? 1 : 0;
  16 }
  17
  18 my @tests = (
  19         'a.b.c.d' => 0,                 # no @
  20         'a@b' => 0,                     # no dot in domain
  21         'a@b.c' => 1,                   # ok
  22         'a@b@c.d' => 0,                 # multiple @'s
  23         '"a@b"@c.d' => 1,               # but ok in quotes
  24         'a b@c.d' => 0,                 # spaces not permitted
  25         '"a b"@c.d' => 1,               # but again they are ok when quoted
  26         '"x y"z@c.d' => 0,              # quoting must not be partial
  27         '""@c.d' => 1,                  # strange, but correct
  28         '!#$%&*+-/=?^_`{}|@c.d' => 1,   # all sorts of perrmited weird chars
  29         '"a \"\\@\@"@c.d' => 1,         # backslash escapes
  30         '"\"@c.d' => 0,                 # misquoted
  31         '...@c.d' => 1,                 # RFC disallows this, but generally accepted
  32         'baba@a b.cz' => 0,             # no spaces in domain
  33         'ganesha@a.' => 0,              # dot here is not enough
  34         'ganesha@a.b.' => 1,            # but trailing dots are ok, although not canonical
  35         'odin@[1.2.3.4]' => 1,          # numeric address
  36         'odin@1.2.3.4' => 1,            # correct, although probably undeliverable
  37         'odin@[valhalla . gov]' => 1,   # spaces allowed here
  38         'odin@[val\[halla\].\\gov]' => 1,  # escapes as well
  39         'odin@[val\]' => 0,             # but we must not forget to close ]
  40         'odin@[abc].def' => 0,          # mixed is invalid
  41         '"@"@[@.@]' => 1,               # wow!
  42         '[@.@]@[@.@]' => 0,             # but this is not OK (unquoted "[")
  43         'a@a..b' => 1,                  # undeliverable, but syntactically OK
  44 );
  45
  46 print "Testing:\n";
  47 while (@tests) {
  48         my $addr = shift @tests;
  49         my $res = email_ok($addr);
  50         print "$addr: $res\n";
  51         $res == shift @tests or die "Test failed";
  52 }
  53 print "All tests passed.\n\nTry yourself:\n";
  54 while (<>) {
  55         chomp;
  56         print email_ok($_), "\n";
  57 }