Re: PATCH: allow regular expressions for address matching to be easily overridden

[Jared Johnson]

Robin Bowes wrote:
Any reason this, and most/all the other regex definitions are not qr{...} ?

Good idea!  Attached a new patch.  Tested with normal address syntax and 
u...@[ip] syntax, with $Qpsmtpd::Address::address_literal_expr set and 
unset... it might need some closer review for any other cases of syntax 
that I don't really understand.

This patch also includes a showstopper fix I made in testing that didn't 
make into my first patch:

- my ($localpart, $domainpart) = ($path =~ /^(.*)\@(${domain_expr})$/);
+ my ($localpart, $domainpart) = ($path =~ /^(.*)\@(${domain})$/);

Enjoy!

-Jared

--- lib/Qpsmtpd/Address.pm	2008-11-11 16:55:50.000000000 -0600
+++ /home/jaredj/svn/dc-smtpd-upstream/lib/Qpsmtpd/Address.pm	2008-12-23 12:41:21.000000000 -0600
@@ -178,23 +178,26 @@
 
 =cut
 
+our $atom_expr = qr/[a-zA-Z0-9!#%&*+=?^_`{|}~\$\x27\x2D\/]+/;
+our $address_literal_expr = 
+  qr/(?:\[(?:\d{1,3}\.\d{1,3}\.\d{1,3}\.\d{1,3}|IPv6:[0-9A-Fa-f:.]+)\])/;
+our $subdomain_expr = qr/(?:[a-zA-Z0-9](?:[-a-zA-Z0-9]*[a-zA-Z0-9])?)/;
+our $domain_expr;
+our $qtext_expr = qr/[\x01-\x08\x0B\x0C\x0E-\x1F\x21\x23-\x5B\x5D-\x7F]/;
+our $text_expr = qr/[\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 : qr/${subdomain_expr}(?:\.${subdomain_expr})*/;
+    $domain = qr/(?:${address_literal_expr}|${domain})/ if !$domain_expr and $address_literal_expr;
     # strip source route
-    $path =~ s/^...@$domain(?:,\...@$domain)*://;
+    $path =~ s/^...@${domain}(?:,\...@${domain})*://;
 
     # empty path is ok
     return "" if $path eq "";
@@ -202,16 +205,16 @@
     # bare postmaster is permissible, perl RFC-2821 (4.5.1)
     return ("postmaster", undef) if $path eq "postmaster";
     
-    my ($localpart, $domainpart) = ($path =~ /^(.*)\@($domain)$/);
+    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);