]> Sergey Matveev's repositories - public-inbox.git/blob - lib/PublicInbox/EmlContentFoo.pm
ds: support greeting protocols
[public-inbox.git] / lib / PublicInbox / EmlContentFoo.pm
1 # Copyright (C) 2020-2021 all contributors <meta@public-inbox.org>
2 # Copyright (C) 2004- Simon Cozens, Casey West, Ricardo SIGNES
3 # This library is free software; you can redistribute it and/or modify
4 # it under the same terms as Perl itself.
5 #
6 # License: GPL-1.0+ or Artistic-1.0-Perl
7 #  <https://www.gnu.org/licenses/gpl-1.0.txt>
8 #  <https://dev.perl.org/licenses/artistic.html>
9 #
10 # This license differs from the rest of public-inbox
11 #
12 # ABSTRACT: Parse a MIME Content-Type or Content-Disposition Header
13 #
14 # This is a fork of the Email::MIME::ContentType 1.022 with
15 # minor improvements and incompatibilities; namely changes to
16 # quiet warnings with legacy data.
17 package PublicInbox::EmlContentFoo;
18 use strict;
19 use parent qw(Exporter);
20 use v5.10.1;
21
22 # find_mime_encoding() only appeared in Encode 2.87+ (Perl 5.26+),
23 # while we support 2.35 shipped with Perl 5.10.1
24 use Encode 2.35 qw(find_encoding);
25 my %mime_name_map; # $enc->mime_name => $enc object
26 BEGIN {
27         eval { Encode->import('find_mime_encoding') };
28         if ($@) {
29                 *find_mime_encoding = sub { $mime_name_map{lc($_[0])} };
30                 %mime_name_map = map {;
31                         my $enc = find_encoding($_);
32                         my $m = lc($enc->mime_name // '');
33                         $m => $enc;
34                 } Encode->encodings(':all');
35
36                 # delete fallback for encodings w/o ->mime_name:
37                 delete $mime_name_map{''};
38
39                 # an extra alias see Encode::MIME::NAME
40                 $mime_name_map{'utf8'} = find_encoding('UTF-8');
41         }
42 }
43
44 our @EXPORT_OK = qw(parse_content_type parse_content_disposition);
45
46 our $STRICT_PARAMS = 1;
47
48 my $ct_default = 'text/plain; charset=us-ascii';
49
50 my $re_token = # US-ASCII except SPACE, CTLs and tspecials ()<>@,;:\\"/[]?=
51         qr/[\x21\x23-\x27\x2A\x2B\x2D\x2E\x30-\x39\x41-\x5A\x5E-\x7E]+/;
52
53 my $re_token_non_strict = # allow CTLs and above ASCII
54         qr/([\x00-\x08\x0B\x0C\x0E-\x1F\x7E-\xFF]+|$re_token)/;
55
56 my $re_qtext = # US-ASCII except CR, LF, white space, backslash and quote
57         qr/[\x01-\x08\x0B\x0C\x0E-\x1F\x21\x23-\x5B\x5D-\x7E\x7F]/;
58 my $re_quoted_pair = qr/\\[\x00-\x7F]/;
59 my $re_quoted_string = qr/"((?:[ \t]*(?:$re_qtext|$re_quoted_pair))*[ \t]*)"/;
60
61 my $re_qtext_non_strict = qr/[\x80-\xFF]|$re_qtext/;
62 my $re_quoted_pair_non_strict = qr/\\[\x00-\xFF]/;
63 my $re_quoted_string_non_strict =
64 qr/"((?:[ \t]*(?:$re_qtext_non_strict|$re_quoted_pair_non_strict))*[ \t]*)"/;
65
66 my $re_charset = qr/[!"#\$%&'+\-0-9A-Z\\\^_`a-z\{\|\}~]+/;
67 my $re_language = qr/[A-Za-z]{1,8}(?:-[0-9A-Za-z]{1,8})*/;
68 my $re_exvalue = qr/($re_charset)?'(?:$re_language)?'(.*)/;
69
70 sub parse_content_type {
71         my ($ct) = @_;
72
73         # If the header isn't there or is empty, give default answer.
74         $ct = $ct_default unless defined($ct) && length($ct);
75
76         _unfold_lines($ct);
77         _clean_comments($ct);
78
79         # It is also recommend (sic.) that this default be assumed when a
80         # syntactically invalid Content-Type header field is encountered.
81         unless ($ct =~ s/^($re_token)\/($re_token)//) {
82                 unless ($STRICT_PARAMS && $ct =~ s/^($re_token_non_strict)\/
83                                                 ($re_token_non_strict)//x) {
84                         #carp "Invalid Content-Type '$ct'";
85                         return parse_content_type($ct_default);
86                 }
87         }
88
89         my ($type, $subtype) = (lc $1, lc $2);
90
91         _clean_comments($ct);
92         $ct =~ s/\s+$//;
93
94         my $attributes = {};
95         if ($STRICT_PARAMS && length($ct) && $ct !~ /^;/) {
96                 # carp "Missing ';' before first Content-Type parameter '$ct'";
97         } else {
98                 $attributes = _process_rfc2231(_parse_attributes($ct));
99         }
100
101         {
102                 type       => $type,
103                 subtype => $subtype,
104                 attributes => $attributes,
105         };
106 }
107
108 my $cd_default = 'attachment';
109
110 sub parse_content_disposition {
111         my ($cd) = @_;
112
113         $cd = $cd_default unless defined($cd) && length($cd);
114
115         _unfold_lines($cd);
116         _clean_comments($cd);
117
118         unless ($cd =~ s/^($re_token)//) {
119                 unless ($STRICT_PARAMS and $cd =~ s/^($re_token_non_strict)//) {
120                         #carp "Invalid Content-Disposition '$cd'";
121                         return parse_content_disposition($cd_default);
122                 }
123         }
124
125         my $type = lc $1;
126
127         _clean_comments($cd);
128         $cd =~ s/\s+$//;
129
130         my $attributes = {};
131         if ($STRICT_PARAMS && length($cd) && $cd !~ /^;/) {
132 # carp "Missing ';' before first Content-Disposition parameter '$cd'";
133         } else {
134                 $attributes = _process_rfc2231(_parse_attributes($cd));
135         }
136
137         {
138                 type       => $type,
139                 attributes => $attributes,
140         };
141 }
142
143 sub _unfold_lines {
144         $_[0] =~ s/(?:\r\n|[\r\n])(?=[ \t])//g;
145 }
146
147 sub _clean_comments {
148         my $ret = ($_[0] =~ s/^\s+//);
149         while (length $_[0]) {
150                 last unless $_[0] =~ s/^\(//;
151                 my $level = 1;
152                 while (length $_[0]) {
153                         my $ch = substr $_[0], 0, 1, '';
154                         if ($ch eq '(') {
155                                 $level++;
156                         } elsif ($ch eq ')') {
157                                 $level--;
158                                 last if $level == 0;
159                         } elsif ($ch eq '\\') {
160                                 substr $_[0], 0, 1, '';
161                         }
162                 }
163                 # carp "Unbalanced comment" if $level != 0 and $STRICT_PARAMS;
164                 $ret |= ($_[0] =~ s/^\s+//);
165         }
166         $ret;
167 }
168
169 sub _process_rfc2231 {
170         my ($attribs) = @_;
171         my %cont;
172         my %encoded;
173         foreach (keys %{$attribs}) {
174                 next unless $_ =~ m/^(.*)\*([0-9])\*?$/;
175                 my ($attr, $sec) = ($1, $2);
176                 $cont{$attr}->[$sec] = $attribs->{$_};
177                 $encoded{$attr}->[$sec] = 1 if $_ =~ m/\*$/;
178                 delete $attribs->{$_};
179         }
180         foreach (keys %cont) {
181                 my $key = $_;
182                 $key .= '*' if $encoded{$_};
183                 $attribs->{$key} = join '', @{$cont{$_}};
184         }
185         foreach (keys %{$attribs}) {
186                 next unless $_ =~ m/^(.*)\*$/;
187                 my $key = $1;
188                 next unless ($attribs->{$_} // '') =~ m/^$re_exvalue$/;
189                 my ($charset, $value) = ($1, $2);
190                 $value =~ s/%([0-9A-Fa-f]{2})/pack('C', hex($1))/eg;
191                 if (length $charset) {
192                         my $enc = find_mime_encoding($charset);
193                         if (defined $enc) {
194                                 $value = $enc->decode($value);
195                         # } else {
196                                 #carp "Unknown charset '$charset' in
197                                 #attribute '$key' value";
198                         }
199                 }
200                 $attribs->{$key} = $value;
201                 delete $attribs->{$_};
202         }
203         $attribs;
204 }
205
206 sub _parse_attributes {
207         local $_ = shift;
208         substr($_, 0, 0, '; ') if length $_ and $_ !~ /^;/;
209         my $attribs = {};
210         while (length $_) {
211                 s/^;// or $STRICT_PARAMS and do {
212                         #carp "Missing semicolon before parameter '$_'";
213                         return $attribs;
214                 };
215                 _clean_comments($_);
216                 unless (length $_) {
217                         # Some mail software generates a Content-Type like this:
218                         # "Content-Type: text/plain;"
219                         # RFC 1521 section 3 says a parameter must exist if
220                         # there is a semicolon.
221                         #carp "Extra semicolon after last parameter" if
222                         #$STRICT_PARAMS;
223                         return $attribs;
224                 }
225                 my $attribute;
226                 if (s/^($re_token)=//) {
227                         $attribute = lc $1;
228                 } else {
229                         if ($STRICT_PARAMS) {
230                                 # carp "Illegal parameter '$_'";
231                                 return $attribs;
232                         }
233                         if (s/^($re_token_non_strict)=//) {
234                                 $attribute = lc $1;
235                         } else {
236                                 unless (s/^([^;=\s]+)\s*=//) {
237                                         #carp "Cannot parse parameter '$_'";
238                                         return $attribs;
239                                 }
240                                 $attribute = lc $1;
241                         }
242                 }
243                 _clean_comments($_);
244                 my $value = _extract_attribute_value();
245                 $attribs->{$attribute} = $value;
246                 _clean_comments($_);
247         }
248         $attribs;
249 }
250
251 sub _extract_attribute_value { # EXPECTS AND MODIFIES $_
252         my $value;
253         while (length $_) {
254                 if (s/^($re_token)//) {
255                         $value .= $1;
256                 } elsif (s/^$re_quoted_string//) {
257                         my $sub = $1;
258                         $sub =~ s/\\(.)/$1/g;
259                         $value .= $sub;
260                 } elsif ($STRICT_PARAMS) {
261                         #my $char = substr $_, 0, 1;
262                         #carp "Unquoted '$char' not allowed";
263                         return;
264                 } elsif (s/^($re_token_non_strict)//) {
265                         $value .= $1;
266                 } elsif (s/^$re_quoted_string_non_strict//) {
267                         my $sub = $1;
268                         $sub =~ s/\\(.)/$1/g;
269                         $value .= $sub;
270                 }
271                 my $erased = _clean_comments($_);
272                 last if !length $_ or /^;/;
273                 if ($STRICT_PARAMS) {
274                         #my $char = substr $_, 0, 1;
275                         #carp "Extra '$char' found after parameter";
276                         return;
277                 }
278                 if ($erased) {
279                         # Sometimes semicolon is missing, so check for = char
280                         last if m/^$re_token_non_strict=/;
281                         $value .= ' ';
282                 }
283                 $value .= substr $_, 0, 1, '';
284         }
285         $value;
286 }
287
288 1;
289 __END__
290 =func parse_content_type
291
292 This routine is exported by default.
293
294 This routine parses email content type headers according to section 5.1 of RFC
295 2045 and also RFC 2231 (Character Set and Parameter Continuations).  It returns
296 a hash as above, with entries for the C<type>, the C<subtype>, and a hash of
297 C<attributes>.
298
299 =func parse_content_disposition
300
301 This routine is exported by default.
302
303 This routine parses email Content-Disposition headers according to RFC 2183 and
304 RFC 2231.  It returns a hash as above, with entries for the C<type>, and a hash
305 of C<attributes>.
306
307 =cut