File Coverage

blib/lib/Sietima/Role/Headers.pm
Criterion Covered Total %
statement 60 60 100.0
branch 12 20 60.0
condition n/a
subroutine 11 11 100.0
pod n/a
total 83 91 91.2


line stmt bran cond sub pod time code
1             package Sietima::Role::Headers;
2 2     2   1027 use Moo::Role;
  2         5  
  2         15  
3 2     2   831 use Try::Tiny;
  2         6  
  2         119  
4 2     2   12 use Sietima::Policy;
  2         4  
  2         16  
5 2     2   875 use Sietima::HeaderURI;
  2         9  
  2         117  
6 2     2   19 use Email::Address;
  2         7  
  2         146  
7 2     2   15 use Types::Standard qw(Str);
  2         6  
  2         21  
8 2     2   1892 use Sietima::Types qw(HeaderUriFromThings);
  2         6  
  2         17  
9 2     2   990 use namespace::clean;
  2         4  
  2         15  
10              
11             our $VERSION = '1.0.3'; # VERSION
12             # ABSTRACT: adds standard list-related headers to messages
13              
14              
15             has name => (
16             isa => Str,
17             is => 'ro',
18             required => 0,
19             );
20              
21 10 50   10   27 sub _normalise_address($self,$address) {
  10 50       25  
  10         21  
  10         20  
  10         18  
22 10 100       39 my @items = ref($address) eq 'ARRAY' ? $address->@* : $address;
23              
24             return map {
25 10         20 HeaderUriFromThings->coerce($_)
  11         97  
26             } @items;
27             }
28              
29 10 50   10   31 sub _set_header($self,$mail,$name,$value) {
  10 50       39  
  10         17  
  10         18  
  10         19  
  10         18  
  10         18  
30 10         47 my $header_name = 'List-' . ucfirst($name =~ s{[^[:alnum:]]+}{-}gr);
31 10         37 my @items = $self->_normalise_address($value);
32              
33             $mail->header_raw_set(
34 10         3153 $header_name => join ', ', map { $_->as_header_raw } @items,
  11         38  
35             );
36             }
37              
38 3 50   3   15 sub _add_headers_to($self,$message) {
  3 50       14  
  3         10  
  3         7  
  3         5  
39 3         75 my $addresses = $self->list_addresses;
40 3         983 my $mail = $message->mail;
41              
42             # see RFC 2919 "List-Id: A Structured Field and Namespace for the
43             # Identification of Mailing Lists"
44 3         13 my $return_path = delete $addresses->{return_path};
45 3 50       34 if (my $name = $self->name) {
46 3         20 $mail->header_raw_set(
47             'List-Id',
48             sprintf '%s <%s>', $name,$return_path->address =~ s{\@}{.}r,
49             );
50             }
51              
52             # if nobody declared a "post" address, let's guess it's the same
53             # as the address we send from
54 3 100       284 if (not exists $addresses->{post}) {
    50          
55 2         42 $self->_set_header( $mail, post => $return_path );
56             }
57             # but if they explicitly set a false value, this list does not
58             # allow posting, so we need to set the special value 'NO'
59             elsif (not $addresses->{post}) {
60 1         2 delete $addresses->{post};
61 1         6 $mail->header_raw_set('List-Post','NO');
62             }
63             # otherwise we can treat 'post' as normal
64              
65 3         204 for my $name (sort keys $addresses->%*) {
66 8         316 $self->_set_header( $mail, $name => $addresses->{$name} );
67             }
68 3         223 return;
69             }
70              
71              
72             around munge_mail => sub ($orig,$self,$mail) {
73             my @messages = $self->$orig($mail);
74             $self->_add_headers_to($_) for @messages;
75             return @messages;
76             };
77              
78             1;
79              
80             __END__
81              
82             =pod
83              
84             =encoding UTF-8
85              
86             =head1 NAME
87              
88             Sietima::Role::Headers - adds standard list-related headers to messages
89              
90             =head1 VERSION
91              
92             version 1.0.3
93              
94             =head1 SYNOPSIS
95              
96             my $sietima = Sietima->with_traits('Headers')->new({
97             %args,
98             name => $name_of_the_list,
99             });
100              
101             =head1 DESCRIPTION
102              
103             A L<< C<Sietima> >> list with this role applied will add, to each
104             outgoing message, the set of headers defined in RFC 2919 and RFC 2369.
105              
106             This role uses the L<< C<list_addresses>|Sietima/list_addresses >>
107             method to determine what headers to add.
108              
109             If the C<name> attribute is set, a C<List-Id:> header will be added,
110             with a value built out of the name and the C<<
111             $self->list_addresses->{return_path} >> value (which is normally the
112             same as the L<< C<return_path>|Sietima/return_path >> attribute).
113              
114             Other C<List-*:> headers are built from the other values in the
115             C<list_addresses> hashref. Each of those values can be:
116              
117             =over 4
118              
119             =item *
120              
121             an L<< C<Sietima::HeaderURI> >> object
122              
123             =item *
124              
125             a thing that can be passed to that class's constructor:
126              
127             =over 4
128              
129             =item *
130              
131             an L<< C<Email::Address> >> object
132              
133             =item *
134              
135             a L<< C<URI> >> object
136              
137             =item *
138              
139             a string parseable as either
140              
141             =back
142              
143             =item *
144              
145             an arrayref containing any mix of the above
146              
147             =back
148              
149             As a special case, if C<< $self->list_addresses->{post} >> exists and
150             is false, the C<List-Post> header will have the value C<NO> to
151             indicate that the list does not accept incoming messages (e.g. it's an
152             announcement list).
153              
154             =head1 ATTRIBUTES
155              
156             =head2 C<name>
157              
158             Optional string, the name of the mailing list. If this attribute is
159             set, a C<List-Id:> header will be added, with a value built out of the
160             name and the C<< $self->list_addresses->{return_path} >> value (which
161             is normally the same as the L<< C<return_path>|Sietima/return_path >>
162             attribute).
163              
164             =head1 MODIFIED METHODS
165              
166             =head2 C<munge_mail>
167              
168             This method adds list-management headers to each message returned by
169             the original method.
170              
171             =head1 AUTHOR
172              
173             Gianni Ceccarelli <dakkar@thenautilus.net>
174              
175             =head1 COPYRIGHT AND LICENSE
176              
177             This software is copyright (c) 2017 by Gianni Ceccarelli <dakkar@thenautilus.net>.
178              
179             This is free software; you can redistribute it and/or modify it under
180             the same terms as the Perl 5 programming language system itself.
181              
182             =cut