File Coverage

blib/lib/Email/Sender/Transport/Redirect.pm
Criterion Covered Total %
statement 11 11 100.0
branch n/a
condition n/a
subroutine 4 4 100.0
pod n/a
total 15 15 100.0


line stmt bran cond sub pod time code
1             package Email::Sender::Transport::Redirect;
2             {
3             $Email::Sender::Transport::Redirect::VERSION = '0.005';
4             }
5              
6             =head1 NAME
7              
8             Email::Sender::Transport::Redirect - Intercept all emails and redirect them to a specific address
9              
10             =head1 VERSION
11              
12             Version 0.005
13              
14             =head1 SYNOPSIS
15              
16             $transport_orig = Email::Sender::Transport::Sendmail->new;
17              
18             $transport = Email::Sender::Transport::Redirect->new({transport => $transport_orig,
19             redirect_address => 'shop@nitesi.com',
20             });
21              
22             =head1 DESCRIPTION
23              
24             Transport wrapper for Email::Sender which intercepts all emails and redirects
25             them to a specific address.
26              
27             This transport changes the C and C header in the email and
28             adds a C and C header with
29             the original recipients.
30              
31             =head1 ATTRIBUTES
32              
33             =head2 redirect_address
34              
35             Recipient email address for redirected emails. This value, which can
36             be either a string or an hashref, is passed to the
37             L constructor.
38              
39             =head2 redirect_headers
40              
41             Email headers to be changed, defaults to an
42             array reference containing:
43              
44             =over 4
45              
46             =item To
47              
48             =item CC
49              
50             =back
51              
52             =head2 intercept_prefix
53              
54             Prefix for headers which show the original recipients.
55              
56             Defaults to C.
57              
58             =cut
59              
60 3     3   220703 use Moo;
  3         9191  
  3         12  
61 3     3   2847 use Types::Standard qw/ArrayRef Str Object/;
  3         164390  
  3         26  
62 3     3   3086 use Email::Sender::Transport::Redirect::Recipients;
  3         8  
  3         869  
63              
64             extends 'Email::Sender::Transport::Wrapper';
65              
66             has 'redirect_address' => (is => 'ro',
67             required => 1,
68             );
69              
70             has 'redirect_headers' => (
71             is => 'ro',
72             isa => ArrayRef,
73             default => sub { [qw/To Cc/] },
74             );
75              
76             has 'intercept_prefix' => (
77             is => 'ro',
78             isa => Str,
79             default => 'X-Intercepted-',
80             );
81              
82             has recipients => (is => 'lazy',
83             isa => Object);
84              
85             sub _build_recipients {
86 4     4   1016 my $self = shift;
87 4         48 return Email::Sender::Transport::Redirect::Recipients->new($self->redirect_address);
88             }
89              
90              
91              
92             =head1 METHOD MODIFIERS
93              
94             =head2 send_email
95              
96             Wraps around original method and changes email headers.
97              
98             =cut
99              
100             around send_email => sub {
101             my ($orig, $self, $email, $env, @rest) = @_;
102             my ($email_copy, $env_copy, @values);
103              
104             # copy email object to prevent changes in the original object
105             $email_copy = ref($email)->new($email->as_string);
106              
107             # copy envelope hash reference
108             %$env_copy = %$env;
109              
110             for my $header (@{$self->redirect_headers}) {
111             next unless @values = $email_copy->get_header($header);
112              
113             if ($self->intercept_prefix) {
114             $email_copy->set_header($self->intercept_prefix . $header,
115             @values);
116             }
117             my @replace = map { $self->recipients->replace($_) } @values;
118             $email_copy->set_header($header, @replace);
119             }
120             # if the to was set in the envelope, replace those as well
121             if ($env_copy->{to} and @{$env_copy->{to}}) {
122             $env_copy->{to} = [ map { $self->recipients->replace($_) } @{$env_copy->{to}} ]
123             }
124             # no to in the envelope? then set it
125             else {
126             $env_copy->{to} = [ $self->recipients->to ];
127             }
128             return $self->$orig($email_copy, $env_copy, @rest);
129             };
130              
131             =head1 AUTHOR
132              
133             Stefan Hornburg (Racke), C
134              
135             =head1 ACKNOWLEDGEMENTS
136              
137             Thanks to Peter Mottram for the port to Moo (GH #1).
138              
139             Thanks to Matt Trout for his help regarding the initial write of this
140             module on #dancer IRC.
141              
142             =head1 LICENSE AND COPYRIGHT
143              
144             Copyright 2012-2015 Stefan Hornburg (Racke).
145              
146             This program is free software; you can redistribute it and/or modify it
147             under the terms of either: the GNU General Public License as published
148             by the Free Software Foundation; or the Artistic License.
149              
150             See http://dev.perl.org/licenses/ for more information.
151              
152              
153             =cut
154              
155             1; # End of Email::Sender::Transport::Redirect