rfc5322_email_address_parser

##
## Email address grammer for Parse::RecDescent
##

{
        our $is_obsoleted;
        $skip = '';

        sub Parse::RecDescent::is_obsoleted {
            return $is_obsoleted;
        }
}

##
## [RFC 5322] 3.4. Address Specification
##     http://tools.ietf.org/html/rfc5322#section-3.4
##
address:          mailbox /^\Z/
                  { $return = $item[1]; }
                | group

mailbox:          name_addr
                | addr_spec

name_addr:        display_name(?) angle_addr
                  { $return = $item[2]; }

angle_addr:       CFWS(?) '<' addr_spec '>' CFWS(?)
                  { $return = $item[3]; 1; }
                | obs_angle_addr

group:            display_name ':' group_list(?) ';' CFWS(?)
                  { $return = $item[1] . ':' . join('', @{$item[3]}) . ';' }

display_name:     phrase

mailbox_list:     mailbox c_mailbox(s?)
                  { $return = $item[1] . join('', @{$item[2]}); 1; }
                | obs_mbox_list

c_mailbox:        ',' mailbox

address_list:     address c_address(s?)
                  { $return = $item[1] . join('', @{$item[2]}); 1; }
                | obs_addr_list

c_address:        ',' address

group_list:       mailbox_list
                | CFWS
                | obs_group_list

##
## [RFC 5322] 3.4.1. Addr-Spec Specification
##     http://tools.ietf.org/html/rfc5322#section-3.4.1
##
address_spec:     addr_spec /^\Z/
                  { $return = $item[1]; 1; }

addr_spec:        local_part '@' domain
                  { $return = $item[1] . '@' . $item[3]; 1; }

local_part:       dot_atom
                | quoted_string
                | obs_local_part

domain:           dot_atom
                | domain_literal
                | obs_domain

domain_literal:   CFWS(?) '[' FWS_dtext(s?) FWS(?) ']' CFWS(?)
                  { $return = '[' . join('', @{$item[3]}) . ']'; 1; }

FWS_dtext:        FWS(?) dtext
                  { $return = $item[2]; 1; }

                # Printable US-ASCII
                # characters not including
                # "[", "]", or "\"
dtext:            m{[\x21-\x5A]}    # %d33-90   '!'-
                | m{[\x5E-\x7E]}    # %d94-126
                | obs_dtext

##
## [RFC 5322] 3.2.1. Quoted characters
##     http://tools.ietf.org/html/rfc5322#section-3.2.1
##
quoted_pair:      "\\" VCHAR_or_WSP
                | obs_qp

VCHAR_or_WSP:     VCHAR
                | WSP

##
## [RFC 5322] 3.2.2. Folding White Space and Comments
##     http://tools.ietf.org/html/rfc5322#section-3.2.2
##
FWS:              WSP_CRLF(?) WSP(s)
                  { $return = $item[1] . join('',@{$item[2]}); 1; }
                | obs_FWS

WSP_CRLF:         WSP(s?) CRLF
                  { $return = join('',@{$item[1]}) . $item[2]; 1; }

ctext:            m{[\x21-\x27]}
                | m{[\x2A-\x5B]}
                | m{[\x5D-\x7E]}
                | obs_ctext

ccontent:         ctext
                | quoted_pair
                | comment

comment:          '(' FWS_ccontent(s?) FWS(?) ')'
                  { $return = '(' . join('', $item[2]) . ')'; 1; }

FWS_ccontent:     FWS(?) ccontent
                  { $return = $item[2]; 1; }

CFWS:             FWS_comment(s) FWS(?)
                { $return = join('', @{$item[1]}); 1; }
                | FWS
                { $return = ' '; 1; }

FWS_comment:      FWS(?) comment

##
## [RFC 5322] 3.2.3. Atom
##     http://tools.ietf.org/html/rfc5322#section-3.2.3
##
atext:            ALPHA
                | DIGIT
                | m{[!#$%&'*+\-/=?^_`{|}~]}

atom:             CFWS(?) atext(s) CFWS(?)
                  { $return = join('', @{$item[2]}); 1; }

dot_atom_text:    atext(s) dot_atext(s?)
                  { $return = join('', @{$item[1]}) . join('', @{$item[2]}); 1; }

dot_atext:        "." atext(s)
                  { $return = '.' . join('', @{$item[2]}); 1; }

dot_atom:         CFWS(?) dot_atom_text CFWS(?)
                  { $return = $item[2]; 1; }

specials:         m{[()<>\[\]:;@\\,.]}
                | DQUOTE

##
## [RFC 5322] 3.2.4. Quoted Strings
##     http://tools.ietf.org/html/rfc5322#section-3.2.4
##
qtext:            m{[\x21\x23-\x5B\x5D-\x7E]} | obs_qtext

qcontent:         qtext | quoted_pair

quoted_string:    CFWS(?) DQUOTE FWS_qcontent(s?) FWS(?) DQUOTE CFWS(?)
                  { $return = '"' . join('', @{$item[3]}) . '"'; 1; }

FWS_qcontent:     FWS(?) qcontent
                  { $return = $item[2]; 1; }

DQUOTE:           '"'

##
## [RFC 5322] 3.2.5. Miscellaneous Tokens
##     http://tools.ietf.org/html/rfc5322#section-3.2.5
##
word:             atom
                | quoted_string

phrase:           word(s)
                  { $return = join('', @{$item[1]}); 1; }
                | obs_phrase

###
### [RFC 5322] Obsolated rules
###

##
## [RFC 5322] 4.1. Miscellaneous Obsolete Tokens
##     http://tools.ietf.org/html/rfc5322#section-4.1
##
obs_NO_WS_CTL:    m{[\x01-\x08\x0B\x0C\x0E-\x1F\x7F]}

obs_ctext:        obs_NO_WS_CTL

obs_qtext:        obs_NO_WS_CTL

obs_qp:           "\\" ("\x00" | obs_NO_WS_CTL | LF | CR)

obs_phrase:       word word_dot_CFWS(s?)
                  { $return = $item[1] . join('', @{$item[2]}); 1; }

word_dot_CFWS:    word | "." | CFWS

##
## [RFC 5322] 4.2. Obsolete Folding White Space
##
obs_FWS:          WSP(s) CRLF_WSP(s?)
                  { $is_obsoleted = 1; 1; }

##
## [RFC 5322] 4.4. Obsolete Addressing
##     http://tools.ietf.org/html/rfc5322#section-4.4
##
obs_angle_addr:   CFWS(?) "<" obs_route addr_spec ">" CFWS(?)
                  { $return = $item[4];
                    $is_obsoleted = 1; }

obs_route:        obs_domain_list ":"
                  { $return = $item[1] . ':';
                    $is_obsoleted = 1; }

obs_domain_list:  CFWS_c(s?) '@' domain c_CFWS_at_domain(s?)
                  { $return = join('',@{$item[1]}).'@'. $item[3] . join('', @{$item[4]});
                    $is_obsoleted = 1; }

CFWS_c:           CFWS | ","

c_CFWS_at_domain: "," CFWS(?) at_domain(?)
                  { $return = ',' . join('', @{$item[3]}); 1; }

at_domain:        '@' domain

obs_mbox_list:    CFWS_c(s) mailbox c_mailbox_CFWS(s?)
                  { $return = join('',@{$item[1]}) . $item[2] . join('',@{$item[3]});
                    $is_obsoleted = 1; }

obs_addr_list:    CFWS_c(s) address c_address_CFWS(s?)
                  { $return = join('',@{$item[1]}) . $item[2] . join('',@{$item[3]});
                    $is_obsoleted = 1; }

obs_group_list:   CFWS_c(s) CFWS(?)
                  { $return = join('',@{$item[1]}) . $item[2];
                    $is_obsoleted = 1; }

CFWS_c:           CFWS(?) ","

obs_local_part:   word dot_word(?)
                  { $return = $item[1] . $item[2];
                    $is_obsoleted = 1; }

obs_domain:       atom dot_atom(s?)
                  { $return = $item[1] . join('',@{$item[2]});
                    $is_obsoleted = 1; }

dot_word:         "." word

dot_atom:         "." atom

obs_dtext:        obs_NO_WS_CTL | quoted_pair

c_mailbox_CFWS:   "," mailbox_CFWS(?)

mailbox_CFWS:     mailbox | CFWS

c_address_CFWS:   "," address_CFWS(?)

address_CFWS:     address | CFWS

##
## [RFC 5234] B.1. Core Rules
##     http://tools.ietf.org/html/rfc5234#appendix-B.1
##
WSP:              SP | HTAB

SP:               "\x20"

HTAB:             "\x09"

CRLF:             CR LF

CR:               "\x0D"

LF:               "\x0A"

CRLF_WSP:         CRLF WSP(s)

ALPHA:            m{[A-Za-z]}

DIGIT:            m{\d}

VCHAR:            m{[\x21-\x7E]}

### end of address.rule

## [RFC 5322]
##   Resnick, P., "Internet Message Format", RFC 5322, October 2008.
##     http://tools.ietf.org/html/rfc5322
##
## [RFC 5234]
##   Crocker, D. and P. Overell, "Augmented BNF for Syntax
##            Specifications: ABNF", STD 68, RFC 5234, January 2008.
##     http://tools.ietf.org/html/rfc5234
##