lib/Sietima/Role/Headers.pm


1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102

package Sietima::Role::Headers; 
use Moo::Role;
use Try::Tiny;
use Sietima::Policy;
use Types::Standard qw(Str);
use namespace::clean;
 
# VERSION 
# ABSTRACT: adds standard list-related headers to messages 
 
=head1 SYNOPSIS
 
  my $sietima = Sietima->with_traits('Headers')->new({
   %args,
   name => $name_of_the_list,
  });
 
=head1 DESCRIPTION
 
A L<< C<Sietima> >> list with this role applied will add, to each
outgoing message, the set of headers defined in RFC 2919 and RFC 2369.
 
This role uses the L<< C<list_addresses>|Sietima/list_addresses >>
method to determine what headers to add.
 
If the C<name> attribute is set, a C<List-Id:> header will be added,
with a value built out of the name and the C<<
$self->list_addresses->{return_path} >> value (which is normally the
same as the L<< C<return_path>|Sietima/return_path >> attribute).
 
Other C<List-*:> headers are built from the other values in the
C<list_addresses> hashref. Those values can either be L<<
C<Email::Address> >> objects (in which case the header will have a
C<mailto:> URI as value) or strings (which will be used literally for
the value of the header).
 
=attr C<name>
 
Optional string, the name of the mailing list. If this attribute is
set, a C<List-Id:> header will be added, with a value built out of the
name and the C<< $self->list_addresses->{return_path} >> value (which
is normally the same as the L<< C<return_path>|Sietima/return_path >>
attribute).
 
=cut
 
has name => (
    isa => Str,
    is => 'ro',
    required => 0,
);
 
sub _add_headers_to($self,$message) {
    my $addresses = $self->list_addresses;
    my $mail = $message->mail;
 
    # see RFC 2919 "List-Id: A Structured Field and Namespace for the 
    # Identification of Mailing Lists" 
    my $return_path = delete $addresses->{return_path};
    if (my $name = $self->name) {
        $mail->header_str_set(
            'List-Id',
            sprintf '%s <%s>', $name,$return_path->address =~ s{\@}{.}r,
        );
    }
 
    # if nobody declared a "post" address, let's guess it's the same 
    # as the address we send from 
    $addresses->{post} //= $return_path;
 
    for my $name (sort keys $addresses->%*) {
        my $header_name = 'List-' . ucfirst($name =~ s{[^[:alnum:]]+}{-}gr);
        my $address = $addresses->{$name};
 
        # if it's not an Email::Address obect, we'll just take it as a 
        # string: it could be a non-mailto URI, see RFC 2369 "The Use 
        # of URLs as Meta-Syntax for Core Mail List Commands and their 
        # Transport through Message Header Fields" 
 
        $mail->header_str_set(
            $header_name => try {
                sprintf '<mailto:%s>',$address->address
            } catch { "<$address>" },
        );
    }
    return;
}
 
=modif C<munge_mail>
 
This method adds list-management headers to each message returned by
the original method.
 
=cut
 
around munge_mail => sub ($orig,$self,$mail) {
    my @messages = $self->$orig($mail);
    $self->_add_headers_to($_) for @messages;
    return @messages;
};
 
1;