diff --git a/Changes b/Changes index ba83dec..24572fe 100644 --- a/Changes +++ b/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) diff --git a/lib/Qpsmtpd/Address.pm b/lib/Qpsmtpd/Address.pm index e313177..71558bd 100644 --- a/lib/Qpsmtpd/Address.pm +++ b/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); diff --git a/t/addresses.t b/t/addresses.t index 9ce2daa..c74a534 100644 --- a/t/addresses.t +++ b/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, '', '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, '', 'got the right sender'); + my $command = 'MAIL FROM: SIZE=1230'; is(($smtpd->command($command))[0], 250, $command); is($smtpd->transaction->sender->format, '', 'got the right sender');