File Coverage

blib/lib/Net/DNS/Mailbox.pm
Criterion Covered Total %
statement 37 37 100.0
branch 6 6 100.0
condition 4 4 100.0
subroutine 9 9 100.0
pod 2 2 100.0
total 58 58 100.0


line stmt bran cond sub pod time code
1             package Net::DNS::Mailbox;
2              
3 10     10   794 use strict;
  10         18  
  10         294  
4 10     10   48 use warnings;
  10         19  
  10         548  
5              
6             our $VERSION = (qw$Id: Mailbox.pm 1910 2023-03-30 19:16:30Z willem $)[2];
7              
8              
9             =head1 NAME
10              
11             Net::DNS::Mailbox - DNS mailbox representation
12              
13             =head1 SYNOPSIS
14              
15             use Net::DNS::Mailbox;
16              
17             $mailbox = Net::DNS::Mailbox->new('user@example.com');
18             $address = $mailbox->address;
19              
20             =head1 DESCRIPTION
21              
22             The Net::DNS::Mailbox module implements a subclass of DNS domain name
23             objects representing the DNS coded form of RFC822 mailbox address.
24              
25             The Net::DNS::Mailbox1035 and Net::DNS::Mailbox2535 packages
26             implement mailbox representation subtypes which provide the name
27             compression and canonicalisation specified by RFC1035 and RFC2535.
28             These are necessary to meet the backward compatibility requirements
29             introduced by RFC3597.
30              
31             =cut
32              
33              
34 10     10   581 use integer;
  10         40  
  10         46  
35 10     10   217 use Carp;
  10         19  
  10         783  
36              
37 10     10   86 use base qw(Net::DNS::DomainName);
  10         30  
  10         5691  
38              
39              
40             =head1 METHODS
41              
42             =head2 new
43              
44             $mailbox = Net::DNS::Mailbox->new('John Doe ');
45             $mailbox = Net::DNS::Mailbox->new('john.doe@example.com');
46             $mailbox = Net::DNS::Mailbox->new('john\.doe.example.com');
47              
48             Creates a mailbox object representing the RFC822 mail address specified by
49             the character string argument. An encoded domain name is also accepted for
50             backward compatibility with Net::DNS 0.68 and earlier.
51              
52             The argument string consists of printable characters from the 7-bit
53             ASCII repertoire.
54              
55             =cut
56              
57             sub new {
58 57     57 1 18338 my $class = shift;
59 57         93 local $_ = shift;
60 57 100       493 croak 'undefined mail address' unless defined $_;
61              
62 55         144 s/^.*
63 55         93 s/>.*$//g; # strip excess on right
64 55         90 s/^\@.+://; # strip deprecated source route
65 55         77 s/\\\./\\046/g; # disguise escaped dots
66              
67 55         281 my ( $localpart, @domain ) = split /[@.]([^@;:"]*$)/; # split on rightmost @
68 55   100     231 s/\./\\046/g for $localpart ||= ''; # escape dots in local part
69              
70 55         262 return bless __PACKAGE__->SUPER::new( join '.', $localpart, @domain ), $class;
71             }
72              
73              
74             =head2 address
75              
76             $address = $mailbox->address;
77              
78             Returns a character string containing the RFC822 mailbox address
79             corresponding to the encoded domain name representation described
80             in RFC1035 section 8.
81              
82             =cut
83              
84             sub address {
85 54 100   54 1 510 return unless defined wantarray;
86 22         77 my @label = shift->label;
87 22   100     62 local $_ = shift(@label) || return '<>';
88 19         37 s/\\\\//g; # delete escaped \
89 19         33 s/^\\034(.*)\\034$/"$1"/; # unescape enclosing quotes
90 19         28 s/\\\d\d\d//g; # delete non-printable
91 19         29 s/\\\./\./g; # unescape dots
92 19         32 s/\\//g; # delete escapes
93 19 100       51 return $_ unless scalar(@label);
94 15         81 return join '@', $_, join '.', @label;
95             }
96              
97              
98             ########################################
99              
100             package Net::DNS::Mailbox1035; ## no critic ProhibitMultiplePackages
101             our @ISA = qw(Net::DNS::Mailbox);
102              
103 26     26   79 sub encode { return &Net::DNS::DomainName1035::encode; }
104              
105              
106             package Net::DNS::Mailbox2535; ## no critic ProhibitMultiplePackages
107             our @ISA = qw(Net::DNS::Mailbox);
108              
109 9     9   30 sub encode { return &Net::DNS::DomainName2535::encode; }
110              
111              
112             1;
113             __END__