File Coverage

blib/lib/Email/Sender/Transport/Redirect/Recipients.pm
Criterion Covered Total %
statement 47 48 97.9
branch 21 24 87.5
condition 3 3 100.0
subroutine 8 8 100.0
pod 2 2 100.0
total 81 85 95.2


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;