Author: robert Date: Wed Dec 31 13:35:21 2008 New Revision: 963 Modified: trunk/Changes trunk/lib/Qpsmtpd/Address.pm trunk/t/addresses.t
Log: Allow local sites to override the definition of an email address. Author: Jared Johnson <[email protected]> Modified: trunk/Changes ============================================================================== --- trunk/Changes (original) +++ trunk/Changes Wed Dec 31 13:35:21 2008 @@ -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) Modified: trunk/lib/Qpsmtpd/Address.pm ============================================================================== --- trunk/lib/Qpsmtpd/Address.pm (original) +++ trunk/lib/Qpsmtpd/Address.pm Wed Dec 31 13:35:21 2008 @@ -178,21 +178,31 @@ =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 @@ # 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); Modified: trunk/t/addresses.t ============================================================================== --- trunk/t/addresses.t (original) +++ trunk/t/addresses.t Wed Dec 31 13:35:21 2008 @@ -15,6 +15,9 @@ is(($smtpd->command('MAIL FROM:[email protected]'))[0], 250, 'MAIL FROM:[email protected]'); is($smtpd->transaction->sender->format, '<[email protected]>', 'got the right sender'); +is(($smtpd->command('MAIL FROM:a...@[1.2.3.4]'))[0], 250, 'MAIL FROM:a...@[1.2.3.4]'); +is($smtpd->transaction->sender->format, '<a...@[1.2.3.4]>', 'got the right sender'); + my $command = 'MAIL FROM:<[email protected]> SIZE=1230'; is(($smtpd->command($command))[0], 250, $command); is($smtpd->transaction->sender->format, '<[email protected]>', 'got the right sender');
