byterazor/qpsmtpd
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

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

Browse Source 
git-svn-id: https://svn.perl.org/qpsmtpd/trunk@963 958fd67b-6ff1-0310-b445-bb7760255be9
This commit is contained in:
Jared Johnson 2008-12-31 21:35:21 +00:00 committed by Ask Bjørn Hansen
parent d4743d28b6
commit a248ed56ad
3 changed files with 30 additions and 12 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

5
Changes
View File

@ -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)

34
lib/Qpsmtpd/Address.pm
View File

@ -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);

3
t/addresses.t
View File

@ -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');