Allow local sites to override the definition of an email address.

git-svn-id: https://svn.perl.org/qpsmtpd/trunk@963 958fd67b-6ff1-0310-b445-bb7760255be9

Changes

@@ -54,6 +54,11 @@
 
   Add qpsmtpd-prefork to the install targets (Robin Bowes)
 
+  Address definitions are now package vars and can be overriden for
+  sites that wish to change the definition of an email address. 
+  (Jared Johnson)
+  http://groups.google.com/group/perl.qpsmtpd/browse_thread/thread/35e3a187d8e75cbe
+
 0.43 - February 5, 2008
 
   (This release was mostly done by Matt Sergeant and Hanno Hecker)

lib/Qpsmtpd/Address.pm

@@ -178,21 +178,31 @@ address).  It returns a list of (local-part, domain).
 
 =cut
 
+# address components are defined as package variables so that they can
+# be overriden (in hook_pre_connection, for example) if people have
+# different needs.
+our $atom_expr = '[a-zA-Z0-9!#%&*+=?^_`{|}~\$\x27\x2D\/]+';
+our $address_literal_expr = 
+  '(?:\[(?:\d{1,3}\.\d{1,3}\.\d{1,3}\.\d{1,3}|IPv6:[0-9A-Fa-f:.]+)\])';
+our $subdomain_expr = '(?:[a-zA-Z0-9](?:[-a-zA-Z0-9]*[a-zA-Z0-9])?)';
+our $domain_expr;
+our $qtext_expr = '[\x01-\x08\x0B\x0C\x0E-\x1F\x21\x23-\x5B\x5D-\x7F]';
+our $text_expr  = '[\x01-\x09\x0B\x0C\x0E-\x7F]';
+
 sub canonify {
     my ($dummy, $path) = @_;
-    my $atom = '[a-zA-Z0-9!#\$\%\&\x27\*\+\x2D\/=\?\^_`{\|}~]+';
-    my $address_literal = 
-'(?:\[(?:\d{1,3}\.\d{1,3}\.\d{1,3}\.\d{1,3}|IPv6:[0-9A-Fa-f:.]+)\])';
-    my $subdomain = '(?:[a-zA-Z0-9](?:[-a-zA-Z0-9]*[a-zA-Z0-9])?)';
-    my $domain = "(?:$address_literal|$subdomain(?:\.$subdomain)*)";
-    my $qtext = '[\x01-\x08\x0B\x0C\x0E-\x1F\x21\x23-\x5B\x5D-\x7F]';
-    my $text = '[\x01-\x09\x0B\x0C\x0E-\x7F]';
-
 
     # strip delimiters
     return undef unless ($path =~ /^<(.*)>$/);
     $path = $1;
 
+    my $domain = $domain_expr ? $domain_expr
+                              : "$subdomain_expr(?:\.$subdomain_expr)*";
+    # it is possible for $address_literal_expr to be empty, if a site
+    # doesn't want to allow them
+    $domain = "(?:$address_literal_expr|$domain)"
+      if !$domain_expr and $address_literal_expr;
+
     # strip source route
     $path =~ s/^\@$domain(?:,\@$domain)*://;
 
@@ -201,17 +211,17 @@ sub canonify {
 
     # bare postmaster is permissible, perl RFC-2821 (4.5.1)
     return ("postmaster", undef) if $path eq "postmaster";
-    
+
     my ($localpart, $domainpart) = ($path =~ /^(.*)\@($domain)$/);
     return (undef) unless defined $localpart;
 
-    if ($localpart =~ /^$atom(\.$atom)*/) {
+    if ($localpart =~ /^$atom_expr(\.$atom_expr)*/) {
         # simple case, we are done
         return ($localpart, $domainpart);
       }
-    if ($localpart =~ /^"(($qtext|\\$text)*)"$/) {
+    if ($localpart =~ /^"(($qtext_expr|\\$text_expr)*)"$/) {
         $localpart = $1;
-        $localpart =~ s/\\($text)/$1/g;
+        $localpart =~ s/\\($text_expr)/$1/g;
         return ($localpart, $domainpart);
       }
     return (undef);

t/addresses.t

@@ -15,6 +15,9 @@ is($smtpd->transaction->sender->address, 'ask @perl.org', 'got the right sender'
 is(($smtpd->command('MAIL FROM:ask@perl.org'))[0], 250, 'MAIL FROM:ask@perl.org');
 is($smtpd->transaction->sender->format, '<ask@perl.org>', 'got the right sender');
 
+is(($smtpd->command('MAIL FROM:ask@[1.2.3.4]'))[0], 250, 'MAIL FROM:ask@[1.2.3.4]');
+is($smtpd->transaction->sender->format, '<ask@[1.2.3.4]>', 'got the right sender');
+
 my $command = 'MAIL FROM:<ask@perl.org> SIZE=1230';
 is(($smtpd->command($command))[0], 250, $command);
 is($smtpd->transaction->sender->format, '<ask@perl.org>', 'got the right sender');