line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
package Email::Sender::Transport::Redirect::Recipients; |
2
|
|
|
|
|
|
|
|
3
|
4
|
|
|
4
|
|
12734
|
use strict; |
|
4
|
|
|
|
|
6
|
|
|
4
|
|
|
|
|
95
|
|
4
|
4
|
|
|
4
|
|
12
|
use warnings; |
|
4
|
|
|
|
|
4
|
|
|
4
|
|
|
|
|
77
|
|
5
|
4
|
|
|
4
|
|
424
|
use Moo; |
|
4
|
|
|
|
|
9035
|
|
|
4
|
|
|
|
|
22
|
|
6
|
4
|
|
|
4
|
|
4068
|
use Email::Valid; |
|
4
|
|
|
|
|
320182
|
|
|
4
|
|
|
|
|
145
|
|
7
|
4
|
|
|
4
|
|
499
|
use Types::Standard qw/ArrayRef Str/; |
|
4
|
|
|
|
|
46178
|
|
|
4
|
|
|
|
|
33
|
|
8
|
|
|
|
|
|
|
|
9
|
|
|
|
|
|
|
=head1 NAME |
10
|
|
|
|
|
|
|
|
11
|
|
|
|
|
|
|
Email::Sender::Transport::Redirect::Recipients - handle email address redirect replacements |
12
|
|
|
|
|
|
|
|
13
|
|
|
|
|
|
|
=head1 SYNOPSIS |
14
|
|
|
|
|
|
|
|
15
|
|
|
|
|
|
|
This is a class used internally by |
16
|
|
|
|
|
|
|
L and shouldn't be used directly. |
17
|
|
|
|
|
|
|
|
18
|
|
|
|
|
|
|
my $rec = Email::Sender::Transport::Redirect::Recipients->new($string_or_hashref); |
19
|
|
|
|
|
|
|
|
20
|
|
|
|
|
|
|
print $rec->to; |
21
|
|
|
|
|
|
|
print Dumper($rec->exclude); |
22
|
|
|
|
|
|
|
print $rec->replace('myemail@example'); |
23
|
|
|
|
|
|
|
|
24
|
|
|
|
|
|
|
=head1 CONSTRUCTOR |
25
|
|
|
|
|
|
|
|
26
|
|
|
|
|
|
|
=head2 BUILDARGS |
27
|
|
|
|
|
|
|
|
28
|
|
|
|
|
|
|
=head2 new($string_or_hashref) |
29
|
|
|
|
|
|
|
|
30
|
|
|
|
|
|
|
Either a single email as string, or an hashref which are used to |
31
|
|
|
|
|
|
|
initialize the accessors (see above). If a string is provided, then |
32
|
|
|
|
|
|
|
just C will be set and no exclusions are set. |
33
|
|
|
|
|
|
|
|
34
|
|
|
|
|
|
|
=head1 ACCESSORS |
35
|
|
|
|
|
|
|
|
36
|
|
|
|
|
|
|
=head2 to |
37
|
|
|
|
|
|
|
|
38
|
|
|
|
|
|
|
The main, required email address to use as a redirect. |
39
|
|
|
|
|
|
|
|
40
|
|
|
|
|
|
|
=head2 exclude |
41
|
|
|
|
|
|
|
|
42
|
|
|
|
|
|
|
An arrayref of emails or wildcard expressions. E.g. |
43
|
|
|
|
|
|
|
|
44
|
|
|
|
|
|
|
[ 'mail@example.org', '*@example.org', 'racke@*' ] |
45
|
|
|
|
|
|
|
|
46
|
|
|
|
|
|
|
These emails will not get redirected. |
47
|
|
|
|
|
|
|
|
48
|
|
|
|
|
|
|
=head1 METHODS |
49
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
=head2 replace($string) |
51
|
|
|
|
|
|
|
|
52
|
|
|
|
|
|
|
Main method. When a string is passed, it's checked against the |
53
|
|
|
|
|
|
|
exclusion list. If there is a match, the address passed as argument |
54
|
|
|
|
|
|
|
will be returned, otherwise the C address set in the object will |
55
|
|
|
|
|
|
|
be returned. |
56
|
|
|
|
|
|
|
|
57
|
|
|
|
|
|
|
=cut |
58
|
|
|
|
|
|
|
|
59
|
|
|
|
|
|
|
|
60
|
|
|
|
|
|
|
has to => (is => 'ro', isa => Str, required => 1); |
61
|
|
|
|
|
|
|
has exclude => (is => 'ro', isa => ArrayRef[Str], default => sub { [] }); |
62
|
|
|
|
|
|
|
|
63
|
|
|
|
|
|
|
sub BUILDARGS { |
64
|
9
|
|
|
9
|
1
|
6151
|
my ($class, @args) = @_; |
65
|
9
|
100
|
|
|
|
33
|
die "Only one argument is supported!" unless @args == 1; |
66
|
8
|
|
|
|
|
10
|
my $arg = shift @args; |
67
|
8
|
100
|
|
|
|
23
|
if (my $kind = ref($arg)) { |
68
|
6
|
100
|
|
|
|
14
|
if ($kind eq 'HASH') { |
69
|
5
|
|
|
|
|
13
|
my %hash = %$arg; |
70
|
5
|
|
|
|
|
11
|
foreach my $k (keys %hash) { |
71
|
11
|
100
|
100
|
|
|
56
|
die "Extra argument $k" unless $k eq 'to' || $k eq 'exclude'; |
72
|
|
|
|
|
|
|
} |
73
|
4
|
|
|
|
|
61
|
return \%hash; |
74
|
|
|
|
|
|
|
} |
75
|
1
|
|
|
|
|
8
|
die "Argument must be an hashref with to and exclude keys, you passed a $kind"; |
76
|
|
|
|
|
|
|
} |
77
|
|
|
|
|
|
|
else { |
78
|
2
|
|
|
|
|
30
|
return { to => $arg }; |
79
|
|
|
|
|
|
|
} |
80
|
|
|
|
|
|
|
} |
81
|
|
|
|
|
|
|
|
82
|
|
|
|
|
|
|
has excludes_regexps => (is => 'lazy', isa => ArrayRef); |
83
|
|
|
|
|
|
|
|
84
|
|
|
|
|
|
|
sub _build_excludes_regexps { |
85
|
5
|
|
|
5
|
|
1396
|
my $self = shift; |
86
|
5
|
|
|
|
|
7
|
my @out; |
87
|
5
|
|
|
|
|
4
|
foreach my $exclusion (@{$self->exclude}) { |
|
5
|
|
|
|
|
19
|
|
88
|
6
|
100
|
|
|
|
28
|
if ($exclusion =~ m/\*/) { |
|
|
50
|
|
|
|
|
|
89
|
3
|
|
|
|
|
5
|
my $re = $exclusion; |
90
|
|
|
|
|
|
|
# http://blogs.perl.org/users/mauke/2015/08/converting-glob-patterns-to-regular-expressions.html |
91
|
3
|
|
|
|
|
11
|
$re =~ s{(\W)}{ |
92
|
9
|
100
|
|
|
|
35
|
$1 eq '?' ? '.' : |
|
|
50
|
|
|
|
|
|
93
|
|
|
|
|
|
|
$1 eq '*' ? '.*' : |
94
|
|
|
|
|
|
|
'\\' . $1 |
95
|
|
|
|
|
|
|
}eg; |
96
|
3
|
|
|
|
|
22
|
push @out, qr{$re}; |
97
|
|
|
|
|
|
|
} |
98
|
|
|
|
|
|
|
elsif (my $address = Email::Valid->address($exclusion)) { |
99
|
3
|
|
|
|
|
2646
|
push @out, qr{\Q$address\E}; |
100
|
|
|
|
|
|
|
} |
101
|
|
|
|
|
|
|
else { |
102
|
0
|
|
|
|
|
0
|
die "Exclusion contains an invalid string: $exclusion, nor a wildcard, nor a valid address: $exclusion"; |
103
|
|
|
|
|
|
|
} |
104
|
|
|
|
|
|
|
} |
105
|
5
|
|
|
|
|
82
|
return \@out; |
106
|
|
|
|
|
|
|
} |
107
|
|
|
|
|
|
|
|
108
|
|
|
|
|
|
|
|
109
|
|
|
|
|
|
|
|
110
|
|
|
|
|
|
|
sub replace { |
111
|
21
|
|
|
21
|
1
|
948
|
my ($self, $mail) = @_; |
112
|
21
|
100
|
|
|
|
53
|
if ($mail) { |
113
|
20
|
100
|
|
|
|
18
|
if (my @exclusions = @{$self->excludes_regexps}) { |
|
20
|
|
|
|
|
278
|
|
114
|
|
|
|
|
|
|
# an alternate approach could be Email::Address to allow multiple addresses |
115
|
18
|
50
|
|
|
|
171
|
if (my $address = Email::Valid->address($mail)) { |
116
|
18
|
|
|
|
|
3677
|
my $real = $address . ''; # stringify |
117
|
18
|
|
|
|
|
23
|
foreach my $re (@exclusions) { |
118
|
|
|
|
|
|
|
# print "Checking $real against $re\n"; |
119
|
24
|
100
|
|
|
|
250
|
if ($real =~ m/\A$re\z/) { |
120
|
|
|
|
|
|
|
# print "Found, returning $real\n"; |
121
|
12
|
|
|
|
|
55
|
return $real; |
122
|
|
|
|
|
|
|
} |
123
|
|
|
|
|
|
|
} |
124
|
|
|
|
|
|
|
} |
125
|
|
|
|
|
|
|
} |
126
|
|
|
|
|
|
|
} |
127
|
|
|
|
|
|
|
# fall back |
128
|
|
|
|
|
|
|
# print "Falling back\n"; |
129
|
9
|
|
|
|
|
62
|
return $self->to; |
130
|
|
|
|
|
|
|
} |
131
|
|
|
|
|
|
|
|
132
|
|
|
|
|
|
|
1; |