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   848 use strict;
  10         22  
  10         295  
4 10     10   61 use warnings;
  10         30  
  10         501  
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   579 use integer;
  10         46  
  10         50  
35 10     10   216 use Carp;
  10         26  
  10         802  
36              
37 10     10   68 use base qw(Net::DNS::DomainName);
  10         25  
  10         5930  
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 18811 my $class = shift;
59 57         108 local $_ = shift;
60 57 100       499 croak 'undefined mail address' unless defined $_;
61              
62 55         151 s/^.*
63 55         119 s/>.*$//g; # strip excess on right
64 55         89 s/^\@.+://; # strip deprecated source route
65 55         121 s/\\\./\\046/g; # disguise escaped dots
66              
67 55         323 my ( $localpart, @domain ) = split /[@.]([^@;:"]*$)/; # split on rightmost @
68 55   100     271 s/\./\\046/g for $localpart ||= ''; # escape dots in local part
69              
70 55         278 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 546 return unless defined wantarray;
86 22         75 my @label = shift->label;
87 22   100     65 local $_ = shift(@label) || return '<>';
88 19         38 s/\\\\//g; # delete escaped \
89 19         37 s/^\\034(.*)\\034$/"$1"/; # unescape enclosing quotes
90 19         25 s/\\\d\d\d//g; # delete non-printable
91 19         33 s/\\\./\./g; # unescape dots
92 19         29 s/\\//g; # delete escapes
93 19 100       51 return $_ unless scalar(@label);
94 15         103 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   76 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   78 sub encode { return &Net::DNS::DomainName2535::encode; }
110              
111              
112             1;
113             __END__