File Coverage

blib/lib/Value/Object/EmailAddressCommon.pm
Criterion Covered Total %
statement 40 40 100.0
branch 8 10 80.0
condition 1 3 33.3
subroutine 9 9 100.0
pod 3 3 100.0
total 61 65 93.8


line stmt bran cond sub pod time code
1             package Value::Object::EmailAddressCommon;
2              
3 2     2   26079 use warnings;
  2         4  
  2         53  
4 2     2   8 use strict;
  2         3  
  2         37  
5              
6 2     2   514 use Value::Object::ValidationUtils;
  2         4  
  2         51  
7 2     2   540 use Value::Object::Domain;
  2         3  
  2         64  
8              
9             our $VERSION = '0.13';
10              
11 2     2   14 use parent 'Value::Object';
  2         4  
  2         12  
12              
13             sub _why_invalid
14             {
15 8     8   10 my ($self, $value) = @_;
16 8 100       23 return ( ref($self) . ': undefined value', '', undef ) unless defined $value;
17 7 100       49 return ( ref($self) . ': missing domain', '', undef ) unless $value =~ tr/@//;
18              
19 6         11 my $pos = rindex( $value, '@' );
20             {
21 6         11 my $lp = substr( $value, 0, $pos );
22 6         16 my ($why, $long, $data) = Value::Object::ValidationUtils::why_invalid_common_email_local_part( $lp );
23 6 100       20 return ( ref($self) . ": $why", '', $lp ) if defined $why;
24             }
25              
26             {
27 6         7 my $dom = substr( $value, $pos+1 );
  4         5  
  4         6  
28 4         17 my ($why, $long, $data) = Value::Object::ValidationUtils::why_invalid_domain_name( $dom );
29 4 50       9 return ( ref($self) . ": $why", '', $dom ) if defined $why;
30             }
31 4         8 return;
32             }
33              
34             sub local_part
35             {
36 1     1 1 2 my ($self) = @_;
37 1         4 return substr( $self->value, 0, rindex( $self->value, '@' ) );
38             }
39              
40             sub domain
41             {
42 2     2 1 4 my ($self) = @_;
43 2         7 return Value::Object::Domain->new( substr( $self->value, rindex( $self->value, '@' )+1 ) );
44             }
45              
46             sub new_canonical
47             {
48 3     3 1 2615 my ($class, $value) = @_;
49              
50             # Canonicalize if possible. If not, let normal validation proceed.
51 3 50 33     19 if( defined $value and $value =~ tr/@// )
52             {
53 3         5 my $pos = rindex( $value, '@' );
54 3         6 my $lp = substr( $value, 0, $pos );
55 3         6 my $dom = substr( $value, $pos+1 );
56 3         4 $dom =~ tr/A-Z/a-z/;
57 3         7 $value = "$lp\@$dom";
58             }
59 3         10 return __PACKAGE__->new( $value );
60             }
61              
62             1;
63             __END__