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   845 use strict;
  10         22  
  10         347  
4 10     10   56 use warnings;
  10         18  
  10         530  
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   546 use integer;
  10         34  
  10         594  
35 10     10   251 use Carp;
  10         22  
  10         757  
36              
37 10     10   67 use base qw(Net::DNS::DomainName);
  10         19  
  10         5872  
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 18396 my $class = shift;
59 57         100 local $_ = shift;
60 57 100       474 croak 'undefined mail address' unless defined $_;
61              
62 55         147 s/^.*
63 55         106 s/>.*$//g; # strip excess on right
64 55         83 s/^\@.+://; # strip deprecated source route
65 55         89 s/\\\./\\046/g; # disguise escaped dots
66              
67 55         283 my ( $localpart, @domain ) = split /[@.]([^@;:"]*$)/; # split on rightmost @
68 55   100     235 s/\./\\046/g for $localpart ||= ''; # escape dots in local part
69              
70 55         281 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 497 return unless defined wantarray;
86 22         73 my @label = shift->label;
87 22   100     67 local $_ = shift(@label) || return '<>';
88 19         38 s/\\\\//g; # delete escaped \
89 19         32 s/^\\034(.*)\\034$/"$1"/; # unescape enclosing quotes
90 19         26 s/\\\d\d\d//g; # delete non-printable
91 19         32 s/\\\./\./g; # unescape dots
92 19         29 s/\\//g; # delete escapes
93 19 100       47 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   72 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__