File Coverage

blib/lib/Labyrinth/Constraints/Emails.pm
Criterion Covered Total %
statement 15 37 40.5
branch 0 12 0.0
condition 0 3 0.0
subroutine 5 12 41.6
pod 4 4 100.0
total 24 68 35.2


line stmt bran cond sub pod time code
1             package Labyrinth::Constraints::Emails;
2              
3 3     3   40640 use warnings;
  3         6  
  3         95  
4 3     3   12 use strict;
  3         5  
  3         91  
5              
6 3     3   12 use vars qw($VERSION $AUTOLOAD);
  3         4  
  3         184  
7             $VERSION = '5.32';
8              
9             =head1 NAME
10              
11             Labyrinth::Constraints::Emails - Email Constraint Handler for Labyrinth
12              
13             =head1 DESCRIPTION
14              
15             Validates emails, eith in simplistic terms or according to the RFCs.
16              
17             =cut
18              
19             #----------------------------------------------------------------------------
20             # Exporter Settings
21              
22             require Exporter;
23 3     3   12 use vars qw($VERSION @ISA @EXPORT);
  3         5  
  3         1470  
24             @ISA = qw(Exporter);
25             @EXPORT = qw(
26             emails valid_emails match_emails
27             email_rfc valid_email_rfc match_email_rfc
28             );
29              
30             #----------------------------------------------------------------------------
31             # Variables
32              
33             # RFC 2396, base definitions.
34             my $digit = '[0-9]';
35             my $alpha = '[a-zA-Z]'; # lowalpha | upalpha
36             my $alphanum = '[a-zA-Z0-9]'; # alpha | digit
37              
38             my $IPv4address = qr{ (?: \d+\.\d+\.\d+\.\d+ ) }x;
39             my $toplabel = qr{ (?: $alpha (?: [-a-zA-Z\d]* $alphanum )? ) }x;
40             my $domainlabel = qr{ (?: (?: $alphanum [-a-zA-Z\d]*)? $alphanum ) }x;
41             my $hostname = qr{ (?: (?: $domainlabel\.)+ (?:$toplabel\.)? $alpha{2,} ) }x;
42             my $host = qr{ (?: $hostname | $IPv4address ) }x;
43              
44             # RFC 2822, base definitions.
45             my $atom_strict = qr{[\w!\#\$\%\&\'\*\+\-\/=\?^\`{|}~]}i;
46             my $local_strict = qr{$alphanum(?:\.?$atom_strict)*};
47             my $local_quoted = qr{\"$local_strict(?:\ $local_strict)*\"};
48             my $email_strict = qr{$local_strict\@$host};
49              
50             my $atom_harsh = qr{[\w\'\+\-=]}i;
51             my $local_harsh = qr{$alphanum(?:\.?$atom_harsh)*};
52             my $email_harsh = qr{$local_harsh\@$host};
53              
54             #----------------------------------------------------------------------------
55             # Subroutines
56              
57             =head1 FUNCTIONS
58              
59             =head2 emails
60              
61             Validate email strings against general usage.
62              
63             =over 4
64              
65             =item emails
66              
67             =item valid_emails
68              
69             =item match_emails
70              
71             =back
72              
73             =cut
74              
75             sub emails {
76 0     0 1   my %params = @_;
77             return sub {
78 0     0     my $self = shift;
79 0           $self->set_current_constraint_name('emails');
80 0           $self->valid_emails($self,\%params);
81             }
82 0           }
83              
84             sub match_emails {
85 0     0 1   my ($self,$text) = @_;
86 0 0         return unless $text;
87 0 0         $text =~ m< ^($email_harsh )$ >x ? $1 : undef;
88             }
89              
90             =head2 email_rfc
91              
92             Validate email strings against the RFC specs.
93              
94             =over 4
95              
96             =item email_rfc
97              
98             =item valid_email_rfc
99              
100             =item match_email_rfc
101              
102             =back
103              
104             =cut
105              
106             sub email_rfc {
107 0     0 1   my %params = @_;
108             return sub {
109 0     0     my $self = shift;
110 0           $self->set_current_constraint_name('email_rfc');
111 0           $self->valid_email_rfc(\%params);
112             }
113 0           }
114              
115             sub match_email_rfc {
116 0     0 1   my ($self,$text) = @_;
117 0 0         return unless $text;
118 0 0         $text =~ m< ^( $email_strict )$ >x ? $1 : undef;
119             }
120              
121             sub AUTOLOAD {
122 0     0     my $name = $AUTOLOAD;
123              
124 3     3   14 no strict qw/refs/;
  3         5  
  3         394  
125              
126 0           $name =~ m/^(.*::)(valid_|RE_)(.*)/;
127              
128 0           my ($pkg,$prefix,$sub) = ($1,$2,$3);
129              
130             # Since all the valid_* routines are essentially identical we're
131             # going to generate them dynamically from match_ routines with the same names.
132 0 0 0       if ((defined $prefix) and ($prefix eq 'valid_')) {
133 0 0         return defined &{$pkg.'match_' . $sub}(@_) ? 1 : 0;
  0            
134             }
135             }
136              
137             1;
138              
139             __END__