File Coverage

blib/lib/Lingua/JA/Mail/Header.pm
Criterion Covered Total %
statement 168 177 94.9
branch 27 28 96.4
condition n/a
subroutine 30 31 96.7
pod 11 14 78.5
total 236 250 94.4


line stmt bran cond sub pod time code
1             package Lingua::JA::Mail::Header;
2            
3             our $VERSION = '0.02'; # 2003-04-03 (since 2003-03-05)
4            
5 2     2   31765 use 5.008;
  2         7  
  2         79  
6 2     2   12 use strict;
  2         4  
  2         82  
7 2     2   11 use warnings;
  2         9  
  2         58  
8 2     2   17 use Carp;
  2         4  
  2         199  
9            
10 2     2   2414 use Encode;
  2         30302  
  2         234  
11 2     2   1951 use MIME::Base64;
  2         1970  
  2         4684  
12            
13             sub new {
14 9     9 1 5749 my $class = shift;
15 9         23 my $self = {};
16 9         35 bless $self, $class;
17 9         24 return $self;
18             }
19            
20             sub set {
21 0     0 1 0 my ($self, $entity, $value) = @_;
22 0         0 $$self{$entity} = $value;
23 0         0 return $self;
24             }
25            
26             sub build {
27 4     4 1 25 my $self = shift;
28 4         17 my @key = $self->_header_order;
29 4         8 my @header;
30 4         7 foreach my $key (@key) {
31 20         82 push(@header, "$key: $$self{$key}");
32             }
33 4         43 return join("\n", @header);
34             }
35            
36             sub _header_order {
37 9     9   17 my $self = shift;
38 9         94 my @key = keys(%$self);
39 9         161 my @order = qw(
40             Date From Sender Reply-To To Cc Bcc
41             Message-ID In-Reply-To References
42             Subject Comments Keywords
43             );
44            
45 9         16 my @newkey;
46 9         22 foreach my $order (@order) {
47 117         152 foreach my $key (@key) {
48 689 100       1386 if ($key eq $order) {
49 48         94 push(@newkey, $key);
50             }
51             }
52             }
53            
54 9         18 my @oldkey;
55 9         19 foreach my $key (@key) {
56 53         61 my $exist = 0;
57 53         71 foreach my $newkey (@newkey) {
58 196 100       445 if ($key eq $newkey) {
59 48         54 $exist = 1;
60 48         65 last;
61             }
62             }
63 53 100       127 if ($exist != 1) {
64 5         12 push(@oldkey, $key);
65             }
66             }
67            
68 9         64 return @newkey, @oldkey;
69             }
70             ########################################################################
71             # specify the origination date.
72             sub date {
73 9     9 1 15540 my($self, $date_time) = @_;
74 9         42 $$self{'Date'} = $date_time;
75 9         23 return $self;
76             }
77             ########################################################################
78             # add a originator address or a destination address.
79             sub add_from {
80 15     15 1 86 my($self, $addr_spec, $name) = @_;
81 15         51 $self->_add_mailbox('From', $addr_spec, $name);
82 15         44 return $self
83             }
84            
85             sub sender {
86 3     3 1 35 my($self, $addr_spec, $name) = @_;
87 3         10 $self->_add_mailbox('Sender', $addr_spec, $name);
88 3         10 return $self
89             }
90            
91             sub add_reply {
92 9     9 1 51 my($self, $addr_spec, $name) = @_;
93 9         25 $self->_add_mailbox('Reply-To', $addr_spec, $name);
94 9         85 return $self
95             }
96            
97             sub add_to {
98 27     27 1 373 my($self, $addr_spec, $name) = @_;
99 27         60 $self->_add_mailbox('To', $addr_spec, $name);
100 27         66 return $self
101             }
102            
103             sub add_cc {
104 9     9 1 61 my($self, $addr_spec, $name) = @_;
105 9         27 $self->_add_mailbox('Cc', $addr_spec, $name);
106 9         100 return $self
107             }
108            
109             sub add_bcc {
110 9     9 1 55 my($self, $addr_spec, $name) = @_;
111 9         26 $self->_add_mailbox('Bcc', $addr_spec, $name);
112 9         23 return $self
113             }
114            
115             sub _add_mailbox {
116 72     72   146 my($self, $field, $addr_spec, $name) = @_;
117            
118 72         89 my $address;
119 72 100       136 if ($name) {
120 62 100       121 if ( _check_if_contain_japanese($name) ) {
121 24         49 my $name = encoded_header($name);
122 24         102 $address = "$name\n <$addr_spec>";
123             }
124             else {
125 38 100       87 if ( length($name) <= 73) {
126 16         53 $address = "\"$name\"\n <$addr_spec>";
127             }
128             else {
129 22         88 my @name = split(/ /, $name);
130 22         41 my $too_long_word = 0;
131 22         38 foreach my $piece (@name) {
132 33 100       102 if ( length($piece) > 75 ) {
133 11         13 $too_long_word = 1;
134 11         24 last;
135             }
136             }
137 22 100       46 if ($too_long_word) {
138 11         27 $name = encoded_header_ascii($name);
139 11         36 $address = "$name\n <$addr_spec>";
140             }
141             else {
142 11         30 $name = join("\n ", @name);
143 11         36 $address = "$name\n <$addr_spec>";
144             }
145             }
146             }
147             }
148             else {
149 10         17 $address = $addr_spec;
150             }
151            
152 72 100       1463 if ($$self{$field}) {
153 42 50       90 if ($field eq 'Sender') {
154 0         0 croak "a violation of the RFC2822 - you can specify the 'Sender:' field with only one 'mailbox'";
155             }
156             else {
157 42         164 $$self{$field} = "$$self{$field},\n $address";
158             }
159             }
160             else {
161 30         103 $$self{$field} = "\n $address";
162             }
163            
164 72         3625 return $self;
165             }
166             ########################################################################
167             sub _check_if_contain_japanese {
168 62     62   85 my $string = shift;
169            
170             # $string = decode('utf8', $string);
171 62         169 $string =~ tr/\n//d; # ignore line-break
172 62         179 return $string =~
173             tr/\x01-\x08\x0B\x0C\x0E-\x1F\x7F\x21\x23-\x5B\x5D-\x7E\x20//c;
174             # this tr/// checks if there is other than qtext characters or SPACE.
175             # from RFC2822:
176             # qtext = NO-WS-CTL / %d33 / %d35-91 / %d93-126
177             # qcontent = qtext / quoted-pair
178             # quoted-string = [CFWS] DQUOTE *([FWS] qcontent) [FWS] DQUOTE [CFWS]
179             }
180             ########################################################################
181             sub subject {
182 9     9 1 65 my($self, $string) = @_;
183 9         27 $$self{'Subject'} = encoded_header($string);
184 9         34 $$self{'Subject'} = "\n $$self{'Subject'}";
185 9         28 return $self;
186             }
187             ########################################################################
188            
189             # RFC2822 describes about the length of a line
190             # Max: 998 = 1000 - (CR + LF)
191             # Rec: 76 = 78 - (CR + LF)
192             # RFC2047 describes about the length of an encoded-word
193             # Max: 75 = 76 - SPACE
194            
195             sub encoded_header {
196 33     33 0 42 my ($string) = @_;
197            
198 33         73 my @lines = _encoded_word($string);
199            
200 33         93 my $line = join("\n ", @lines);
201 33         118 return $line;
202             }
203            
204             # an encoded-word is composed of
205             # 'charset', 'encoding', 'encoded-text' and delimiters.
206             # Hence the max length of an encoded-text is:
207             # 75 - ('charset', 'encoding' and delimiters)
208             #
209             # charset 'ISO-2022-JP' is 11.
210             # encoding 'B' is 1.
211             # delimiters '=?', '?', '?' and '?=' is total 6.
212             # 75 - (11 + 1 + 6) = 57
213             # It is said that the max length of an encoded-text is 57
214             # when we use ISO-2022-JP B encoding.
215            
216             sub _encoded_word {
217 33     33   42 my ($string) = @_;
218            
219 33         69 my @words = _encoded_text($string);
220            
221 33         131 foreach my $word (@words) {
222 69         211 $word = "=?ISO-2022-JP?B?$word?=";
223             }
224            
225 33         250 return @words;
226             }
227            
228             # Through Base64 encoding, a group of 4 ASCII-6bit characters
229             # is generated by 3 ASCII-8bit pre-encode characters.
230             # We can get 14 group of encoded 4 ASCII-6bit characters under
231             # the encoded-text's 57 characters limit.
232             # Hence, we may handle max 42 ASCII-8bit characters as
233             # a pre-encode text.
234             # So we should split a ISO-2022-JP text that
235             # each splitted piece's length is within 42
236             # if it is counted as ASCII-8bit characters.
237            
238             sub _encoded_text {
239 33     33   42 my ($string) = @_;
240            
241 33         2077 my @text = _split($string);
242            
243 33         76 foreach my $text (@text) {
244 69         231 $text = encode_base64($text);
245 69         341 $text =~ tr/\n//d;
246             }
247            
248 33         112 return @text;
249             }
250            
251             sub _split {
252 33     33   46 my ($string) = @_;
253            
254 33         34 my @strings;
255 33         74 while ($string) {
256 69         138 (my $piece, $string) = _cut_once($string);
257 69         226 push(@strings, $piece);
258             }
259            
260 33         121 return @strings;
261             }
262            
263             sub _cut_once {
264 69     69   102 my ($string) = @_;
265            
266 69         4823 my $whole = encode('iso-2022-jp', $string);
267 69 100       49527 if ( length($whole) <= 42 ) {
268 33         102 return $whole;
269 0         0 last;
270             }
271            
272 36         73 my $letters = length($string);
273 36         116 for (my $i = 1; $i <= $letters; $i++) {
274 684         1344 my $temp = substr($string, 0, $i);
275 684         1604 $temp = encode('iso-2022-jp', $temp);
276 684 100       73894 if (length($temp) > 42) {
277 36         99 my $piece = substr($string, 0, $i - 1);
278 36         107 $piece = encode('iso-2022-jp', $piece);
279 36         2718 my $rest = substr($string, $i - 1);
280 36         254 return ($piece, $rest);
281 0         0 last;
282             }
283             }
284             }
285             ########################################################################
286             sub encoded_header_ascii {
287 11     11 0 18 my ($string) = @_;
288            
289 11         34 my @lines = _encoded_word_q($string);
290            
291 11         29 my $line = join("\n ", @lines);
292 11         39 return $line;
293             }
294            
295             sub _encoded_word_q {
296 11     11   19 my ($string) = @_;
297            
298 11         30 my @words = _encoded_text_q($string);
299            
300 11         24 foreach my $word (@words) {
301 22         70 $word = "=?US-ASCII?Q?$word?=";
302             }
303            
304 11         37 return @words;
305             }
306            
307             sub _encoded_text_q {
308 11     11   18 my ($string) = @_;
309            
310 11         33 my @text = _split_q($string);
311            
312 11         25 foreach my $text (@text) {
313 22         35 $text = encode_q($text);
314             }
315            
316 11         35 return @text;
317             }
318            
319             sub _split_q {
320 11     11   18 my ($string) = @_;
321            
322 11         14 my @strings;
323 11         30 while ($string) {
324 22         44 (my $piece, $string) = _cut_once_q($string);
325 22         108 push(@strings, $piece);
326             }
327            
328 11         33 return @strings;
329             }
330            
331             sub _cut_once_q {
332 22     22   29 my ($string) = @_;
333            
334 22         44 my $whole = encode_q($string);
335 22 100       61 if ( length($whole) <= 60 ) {
336 11         25 return $string;
337 0         0 last;
338             }
339            
340 11         16 my $letters = length($string);
341 11         66 for (my $i = 1; $i <= $letters; $i++) {
342 671         999 my $temp = substr($string, 0, $i);
343 671         949 $temp = encode_q($temp);
344 671 100       3401 if (length($temp) > 60) {
345 11         28 my $piece = substr($string, 0, $i - 1);
346 11         25 my $rest = substr($string, $i - 1);
347 11         61 return ($piece, $rest);
348 0         0 last;
349             }
350             }
351             }
352            
353             sub encode_q {
354 715     715 0 823 my ($string) = @_;
355            
356 715         1390 $string =~
357 0         0 s/([^\x21\x23-\x3C\x3E\x40-\x5B\x5D\x5E\x60-\x7E])/uc sprintf("=%02x", ord($1))/eg;
358            
359 715         2531 return $string;
360             }
361            
362            
363             1;
364             __END__