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   385628 use strict;
  10         128  
  10         434  
4 10     10   51 use warnings;
  10         19  
  10         920  
5              
6             our $VERSION = (qw$Id: Mailbox.pm 2002 2025-01-07 09:57:46Z 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   699 use integer;
  10         34  
  10         74  
35 10     10   336 use Carp;
  10         20  
  10         1035  
36              
37 10     10   67 use base qw(Net::DNS::DomainName);
  10         20  
  10         7229  
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 30338 my $class = shift;
59 57         119 local $_ = shift;
60 57 100       620 croak 'undefined mail address' unless defined $_;
61              
62 55         169 s/^.*
63 55         138 s/>.*$//g; # strip excess on right
64 55         103 s/^\@.+://; # strip deprecated source route
65 55         106 s/\\\./\\046/g; # disguise escaped dots
66              
67 55         355 my ( $localpart, @domain ) = split /[@.]([^@;:"]*$)/; # split on rightmost @
68 55   100     310 s/\./\\046/g for $localpart ||= ''; # escape dots in local part
69              
70 55         305 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 675 return unless defined wantarray;
86 22         88 my @label = shift->label;
87 22   100     84 local $_ = shift(@label) || return '<>';
88 19         43 s/\\\\//g; # delete escaped \
89 19         43 s/^\\034(.*)\\034$/"$1"/; # unescape enclosing quotes
90 19         31 s/\\\d\d\d//g; # delete non-printable
91 19         39 s/\\\./\./g; # unescape dots
92 19         35 s/\\//g; # delete escapes
93 19 100       60 return $_ unless scalar(@label);
94 15         101 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   84 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   57 sub encode { return &Net::DNS::DomainName2535::encode; }
110              
111              
112             1;
113             __END__