File Coverage

blib/lib/Mail/Builder/TypeConstraints.pm
Criterion Covered Total %
statement 18 18 100.0
branch n/a
condition n/a
subroutine 6 6 100.0
pod n/a
total 24 24 100.0


line stmt bran cond sub pod time code
1             # ============================================================================
2             package Mail::Builder::TypeConstraints;
3             # ============================================================================
4              
5 8     8   43 use strict;
  8         9  
  8         204  
6 8     8   27 use warnings;
  8         9  
  8         150  
7              
8 8     8   26 use namespace::autoclean;
  8         10  
  8         57  
9 8     8   576 use Moose::Util::TypeConstraints;
  8         12  
  8         64  
10              
11 8     8   9730 use Scalar::Util qw(blessed);
  8         12  
  8         381  
12 8     8   3747 use Path::Class::File;
  8         221587  
  8         10092  
13              
14             our $VERSION = $Mail::Builder::VERSION;
15             our $TLDCHECK = Class::Load::try_load_class('Net::Domain::TLD'),
16             our %EMAILVALID = (
17             'tldcheck' => $TLDCHECK,
18             );
19              
20             our $TIMEPART_RE = qr/[0-5]?\d/;
21              
22             # Simple types
23              
24             subtype 'Mail::Builder::Type::Date'
25             => as 'Str'
26             => where { m/^
27             ( Sun | Mon | Tue | Wed | Thu | Fri | Sat )
28             ,
29             \s
30             ( 3[01] | [12] \d | 0? [1-9] )
31             \s
32             ( Jan | Feb | Mar | Apr | May | Jun | Jul | Aug | Sep | Oct | Nov | Dec )
33             \s
34             \d{4}
35             \s
36             ( 2[0-3] | 1\d | 0?\d )
37             :
38             $TIMEPART_RE
39             :
40             $TIMEPART_RE
41             \s
42             [+-]\d{4}
43             $/xi };
44              
45             subtype 'Mail::Builder::Type::DateTime'
46             => as Object
47             => where { $_->isa('DateTime') }
48             => as Int
49             => where {
50             require Email::Date::Format;
51             Email::Date::Format::email_date($_);
52             };
53              
54             coerce 'Mail::Builder::Type::Date'
55             => from 'Mail::Builder::Type::DateTime'
56             => via {
57             return $_->clone->set_locale('en')->format_cldr("ccc, dd MMM yyyy hh:mm:ss ZZZ")
58             };
59              
60             subtype 'Mail::Builder::Type::Content'
61             => as 'ScalarRef';
62              
63             subtype 'Mail::Builder::Type::File'
64             => as class_type('Path::Class::File')
65             => where { -f $_ && -r _ }
66             => message { "Could not open file '$_'" };
67              
68             subtype 'Mail::Builder::Type::Fh'
69             => as class_type('IO::File');
70              
71             coerce 'Mail::Builder::Type::Fh'
72             => from 'GlobRef'
73             => via {
74             return bless($_,'IO::File');
75             };
76              
77             coerce 'Mail::Builder::Type::File'
78             => from 'Str'
79             => via {
80             return Path::Class::File->new($_)
81             };
82              
83             subtype 'Mail::Builder::Type::EmailAddress'
84             => as 'Str'
85             => where {
86             my %params;
87             foreach my $param (qw(rfc822 local_rules fqdn mxcheck tldcheck)) {
88             $params{'-'.$param} = $EMAILVALID{$param}
89             if defined $EMAILVALID{$param};
90             }
91             Email::Valid->address(
92             %params,
93             -address => $_,
94             );
95             }
96             => message { "'$_' is not a valid e-mail address" };
97              
98             subtype 'Mail::Builder::Type::Class'
99             => as 'Str'
100             => where { m/^Mail::Builder::(.+)$/ && Class::Load::is_class_loaded($_) }
101             => message { "'$_' is not a Mail::Builder::* class" };
102              
103             subtype 'Mail::Builder::Type::Priority'
104             => as enum([qw(1 2 3 4 5)]);
105              
106             subtype 'Mail::Builder::Type::ImageMimetype'
107             => as enum([qw(image/gif image/jpeg image/png)])
108             => message { "'$_' is not a valid image MIME-type" };
109              
110              
111             subtype 'Mail::Builder::Type::Mimetype'
112             => as 'Str'
113             => where { m/^(image|message|text|video|x-world|application|audio|model|multipart)\/[^\/]+$/ }
114             => message { "'$_' is not a valid MIME-type" };
115              
116             # Class types
117              
118             subtype 'Mail::Builder::Type::Address'
119             => as class_type('Mail::Builder::Address');
120              
121             coerce 'Mail::Builder::Type::Address'
122             => from 'Defined'
123             => via { Mail::Builder::Address->new( $_ ) };
124              
125             subtype 'Mail::Builder::Type::AddressList'
126             => as class_type('Mail::Builder::List')
127             => where { $_->type eq 'Mail::Builder::Address' }
128             => message { "'$_' is not a Mail::Builder::List of Mail::Builder::Address" };
129              
130             coerce 'Mail::Builder::Type::AddressList'
131             => from 'Mail::Builder::Type::Address'
132             => via { Mail::Builder::List->new( type => 'Mail::Builder::Address', list => [ $_ ] ) }
133             => from 'Str'
134             => via { Mail::Builder::List->new( type => 'Mail::Builder::Address', list => [ Mail::Builder::Address->new($_) ] ) }
135             => from 'HashRef'
136             => via { Mail::Builder::List->new( type => 'Mail::Builder::Address', list => [ Mail::Builder::Address->new($_) ] ) }
137             => from class_type('Email::Address')
138             => via {
139             return Mail::Builder::List->new( type => 'Mail::Builder::Address', list => [
140             Mail::Builder::Address->new($_)
141             ] )
142             }
143             => from 'ArrayRef'
144             => via {
145             my $param = $_;
146             my $result = [];
147             foreach my $element (@$param) {
148             if (blessed $element
149             && $element->isa('Mail::Builder::Address')) {
150             push(@{$result},$element);
151             } else {
152             push(@{$result},Mail::Builder::Address->new($element));
153             }
154             }
155             return Mail::Builder::List->new( type => 'Mail::Builder::Address', list => $result )
156             };
157              
158             subtype 'Mail::Builder::Type::Attachment'
159             => as class_type('Mail::Builder::Attachment');
160              
161             subtype 'Mail::Builder::Type::AttachmentList'
162             => as class_type('Mail::Builder::List')
163             => where { $_->type eq 'Mail::Builder::Attachment' }
164             => message { "'$_' is not a Mail::Builder::List of Mail::Builder::Attachment" };
165              
166             coerce 'Mail::Builder::Type::AttachmentList'
167             => from class_type('Mail::Builder::Attachment')
168             => via { Mail::Builder::List->new( type => 'Mail::Builder::Attachment', list => [ $_ ] ) }
169             => from 'HashRef'
170             => via { Mail::Builder::List->new( type => 'Mail::Builder::Attachment', list => [ Mail::Builder::Attachment->new($_) ] ) }
171             => from 'ArrayRef'
172             => via {
173             my $param = $_;
174             my $result = [];
175             foreach my $element (@$param) {
176             if (blessed $element
177             && $element->isa('Mail::Builder::Attachment')) {
178             push(@{$result},$element);
179             } elsif (ref $element eq 'HASH') {
180             push(@{$result},Mail::Builder::Attachment->new($element));
181             } else {
182             push(@{$result},Mail::Builder::Attachment->new(file => $element));
183             }
184             }
185             return Mail::Builder::List->new( type => 'Mail::Builder::Attachment', list => $result )
186             };
187              
188             subtype 'Mail::Builder::Type::Image'
189             => as class_type('Mail::Builder::Image');
190              
191             subtype 'Mail::Builder::Type::ImageList'
192             => as class_type('Mail::Builder::List')
193             => where { $_->type eq 'Mail::Builder::Image' }
194             => message { "'$_' is not a Mail::Builder::List of Mail::Builder::Image" };
195              
196             coerce 'Mail::Builder::Type::ImageList'
197             => from class_type('Mail::Builder::Image')
198             => via { Mail::Builder::List->new( type => 'Mail::Builder::Image', list => [ $_ ] ) }
199             => from 'HashRef'
200             => via { Mail::Builder::List->new( type => 'Mail::Builder::Image', list => [ Mail::Builder::Image->new($_) ] ) }
201             => from 'ArrayRef'
202             => via {
203             my $param = $_;
204             my $result = [];
205             foreach my $element (@$param) {
206             if (blessed $element
207             && $element->isa('Mail::Builder::Image')) {
208             push(@{$result},$element);
209             } elsif (ref $element eq 'HASH') {
210             push(@{$result},Mail::Builder::Image->new($element));
211             } else {
212             push(@{$result},Mail::Builder::Image->new(file => $element));
213             }
214             }
215             return Mail::Builder::List->new( type => 'Mail::Builder::Image', list => $result )
216             };
217              
218             1;