From db15fbf9ad9eaac9910f12711d6d515fbf206c56 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ask=20Bj=C3=B8rn=20Hansen?= Date: Thu, 15 Jul 2004 22:52:53 +0000 Subject: [PATCH] add the Qpsmtpd::Address module (oops!) git-svn-id: https://svn.perl.org/qpsmtpd/trunk@262 958fd67b-6ff1-0310-b445-bb7760255be9 --- lib/Qpsmtpd/Address.pm | 189 +++++++++++++++++++++++++++++++++++++++++ 1 file changed, 189 insertions(+) create mode 100644 lib/Qpsmtpd/Address.pm diff --git a/lib/Qpsmtpd/Address.pm b/lib/Qpsmtpd/Address.pm new file mode 100644 index 0000000..c5dcd2c --- /dev/null +++ b/lib/Qpsmtpd/Address.pm @@ -0,0 +1,189 @@ +package Qpsmtpd::Address; +use strict; + +sub new { + my ($class, $address) = @_; + my $self = [ ]; + if ($address =~ /^<(.*)>$/) { + $self->[0] = $1; + } else { + $self->[0] = $address; + } + bless ($self, $class); + return $self; +} + +# Definition of an address ("path") from RFC 2821: +# +# Path = "<" [ A-d-l ":" ] Mailbox ">" +# +# A-d-l = At-domain *( "," A-d-l ) +# ; Note that this form, the so-called "source route", +# ; MUST BE accepted, SHOULD NOT be generated, and SHOULD be +# ; ignored. +# +# At-domain = "@" domain +# +# Mailbox = Local-part "@" Domain +# +# Local-part = Dot-string / Quoted-string +# ; MAY be case-sensitive +# +# Dot-string = Atom *("." Atom) +# +# Atom = 1*atext +# +# Quoted-string = DQUOTE *qcontent DQUOTE +# +# Domain = (sub-domain 1*("." sub-domain)) / address-literal +# sub-domain = Let-dig [Ldh-str] +# +# address-literal = "[" IPv4-address-literal / +# IPv6-address-literal / +# General-address-literal "]" +# +# IPv4-address-literal = Snum 3("." Snum) +# IPv6-address-literal = "IPv6:" IPv6-addr +# General-address-literal = Standardized-tag ":" 1*dcontent +# Standardized-tag = Ldh-str +# ; MUST be specified in a standards-track RFC +# ; and registered with IANA +# +# Snum = 1*3DIGIT ; representing a decimal integer +# ; value in the range 0 through 255 +# Let-dig = ALPHA / DIGIT +# Ldh-str = *( ALPHA / DIGIT / "-" ) Let-dig +# +# IPv6-addr = IPv6-full / IPv6-comp / IPv6v4-full / IPv6v4-comp +# IPv6-hex = 1*4HEXDIG +# IPv6-full = IPv6-hex 7(":" IPv6-hex) +# IPv6-comp = [IPv6-hex *5(":" IPv6-hex)] "::" [IPv6-hex *5(":" +# IPv6-hex)] +# ; The "::" represents at least 2 16-bit groups of zeros +# ; No more than 6 groups in addition to the "::" may be +# ; present +# IPv6v4-full = IPv6-hex 5(":" IPv6-hex) ":" IPv4-address-literal +# IPv6v4-comp = [IPv6-hex *3(":" IPv6-hex)] "::" +# [IPv6-hex *3(":" IPv6-hex) ":"] IPv4-address-literal +# ; The "::" represents at least 2 16-bit groups of zeros +# ; No more than 4 groups in addition to the "::" and +# ; IPv4-address-literal may be present +# +# +# +# atext and qcontent are not defined in RFC 2821. +# From RFC 2822: +# +# atext = ALPHA / DIGIT / ; Any character except controls, +# "!" / "#" / ; SP, and specials. +# "$" / "%" / ; Used for atoms +# "&" / "'" / +# "*" / "+" / +# "-" / "/" / +# "=" / "?" / +# "^" / "_" / +# "`" / "{" / +# "|" / "}" / +# "~" +# qtext = NO-WS-CTL / ; Non white space controls +# +# %d33 / ; The rest of the US-ASCII +# %d35-91 / ; characters not including "\" +# %d93-126 ; or the quote character +# +# qcontent = qtext / quoted-pair +# +# NO-WS-CTL = %d1-8 / ; US-ASCII control characters +# %d11 / ; that do not include the +# %d12 / ; carriage return, line feed, +# %d14-31 / ; and white space characters +# %d127 +# +# quoted-pair = ("\" text) / obs-qp +# +# text = %d1-9 / ; Characters excluding CR and LF +# %d11 / +# %d12 / +# %d14-127 / +# obs-text +# +# +# (We ignore all obs forms) + +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; + + # strip source route + $path =~ s/[EMAIL PROTECTED](?:,[EMAIL PROTECTED])*://; + + # empty path is ok + return "" if $path eq ""; + + # + my ($localpart, $domainpart) = ($path =~ /^(.*)\@($domain)$/); + return undef unless (defined $localpart && defined $domainpart); + if ($localpart =~ /^$atom(\.$atom)*/) { + # simple case, we are done + return $path; + } + if ($localpart =~ /^"(($qtext|\\$text)*)"$/) { + $localpart = $1; + $localpart =~ s/\\($text)/$1/g; + return "$localpart\@$domainpart"; + } + return undef; +} + + + +sub parse { + my ($class, $line) = @_; + my $a = $class->canonify($line); + return ($class->new($a)) if (defined $a); + return undef; +} + +sub address { + my ($self, $val) = @_; + my $oldval = $self->[0]; + $self->[0] = $val if (defined($val)); + return $oldval; +} + +sub format { + my ($self) = @_; + my $qchar = '[^a-zA-Z0-9!#\$\%\&\x27\*\+\x2D\/=\?\^_`{\|}~.]'; + my $s = $self->[0]; + return '<>' unless $s; + my ($user, $host) = $s =~ m/(.*)\@(.*)/; + if ($user =~ s/($qchar)/\\$1/g) { + return qq{<"$user"\@$host>}; + } + return "<$s>"; +} + +sub user { + my ($self) = @_; + my ($user, $host) = $self->[0] =~ m/(.*)\@(.*)/; + return $user; +} + +sub host { + my ($self) = @_; + my ($user, $host) = $self->[0] =~ m/(.*)\@(.*)/; + return $host; +} + +1;