File Coverage

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


line stmt bran path cond sub pod time code
1               package Net::DNS::Mailbox;
2                
3 10       10   226091 use strict;
  10           39  
  10           423  
4 10       10   64 use warnings;
  10           18  
  10           811  
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   471 use integer;
  10           27  
  10           76  
35 10       10   255 use Carp;
  10           17  
  10           856  
36                
37 10       10   56 use base qw(Net::DNS::DomainName);
  10           27  
  10           6437  
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 22965 my $class = shift;
59 57           100 local $_ = shift;
60 57 100         454 croak 'undefined mail address' unless defined $_;
61                
62 55           181 s/^.*
63 55           104 s/>.*$//g; # strip excess on right
64 55           79 s/^\@.+://; # strip deprecated source route
65 55           131 s/\\\./\\046/g; # disguise escaped dots
66                
67 55           318 my ( $localpart, @domain ) = split /[@.]([^@;:"]*$)/; # split on rightmost @
68 55     100     233 s/\./\\046/g for $localpart ||= ''; # escape dots in local part
69                
70 55           238 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 413 return unless defined wantarray;
86 22           75 my @label = shift->label;
87 22     100     62 local $_ = shift(@label) || return '<>';
88 19           33 s/\\\\//g; # delete escaped \
89 19           34 s/^\\034(.*)\\034$/"$1"/; # unescape enclosing quotes
90 19           26 s/\\\d\d\d//g; # delete non-printable
91 19           30 s/\\\./\./g; # unescape dots
92 19           24 s/\\//g; # delete escapes
93 19 100         47 return $_ unless scalar(@label);
94 15           84 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   55 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   35 sub encode { return &Net::DNS::DomainName2535::encode; }
110                
111                
112               1;
113               __END__