/[suikacvs]/messaging/manakai/lib/Message/Entity.pm
Suika

Contents of /messaging/manakai/lib/Message/Entity.pm

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.23 - (hide annotations) (download)
Tue Jul 2 06:37:56 2002 UTC (24 years ago) by wakaba
Branch: MAIN
Changes since 1.22: +4 -10 lines
2002-07-02  Wakaba <w@suika.fam.cx>

	* Util.pm (decide_newline): New function.
	* Entity.pm (parse): Call Message::Util::decide_newline
	instead of local code.

1 wakaba 1.1
2     =head1 NAME
3    
4     Message::Entity Perl module
5    
6     =head1 DESCRIPTION
7    
8     Perl module for RFC 822/2822 C<message>.
9     MIME multipart will be also supported (but not implemented yet).
10    
11     =cut
12    
13     package Message::Entity;
14     use strict;
15 wakaba 1.15 use vars qw(%DEFAULT $VERSION);
16 wakaba 1.23 $VERSION=do{my @r=(q$Revision: 1.22 $=~/\d+/g);sprintf "%d."."%02d" x $#r,@r};
17 wakaba 1.1
18 wakaba 1.15 require Message::Util;
19 wakaba 1.8 require Message::Header;
20 wakaba 1.15 require Message::MIME::MediaType;
21     require Message::MIME::Encoding;
22 wakaba 1.9 use overload '""' => sub { $_[0]->stringify },
23     fallback => 1;
24 wakaba 1.1
25 wakaba 1.14 ## Initialize of this class -- called by constructors
26     %DEFAULT = (
27 wakaba 1.15 -_METHODS => [qw|header body content_type id|],
28 wakaba 1.17 -_MEMBERS => [qw|header body _cte|],
29 wakaba 1.18 ## entity_header -- Don't clone.
30 wakaba 1.15 -accept_coderange => '7bit', ## 7bit / 8bit / binary
31 wakaba 1.18 #add_ua => 1,
32 wakaba 1.15 -body_default_charset => 'iso-2022-int-1',
33 wakaba 1.18 -body_default_charset_input => 'iso-2022-int-1',
34     -body_default_media_type => 'text',
35     -body_default_media_subtype => 'plain',
36 wakaba 1.17 -cte_default => '7bit',
37 wakaba 1.8 #fill_date => 1,
38 wakaba 1.15 -fill_date_name => 'date',
39 wakaba 1.8 #fill_msgid => 1,
40 wakaba 1.15 -fill_msgid_name => 'message-id',
41 wakaba 1.19 -force_mime_entity => 0,
42 wakaba 1.15 -format => 'mail-rfc2822',
43 wakaba 1.22 -header_default_charset => 'iso-2022-int-1',
44     -header_default_charset_input => 'iso-2022-int-1',
45 wakaba 1.15 -linebreak_strict => 0, ## BUG: not work perfectly
46     -parse_all => 0,
47 wakaba 1.17 -text_coderange => 'binary',
48     ## '8bit' (MIME text/*) / 'binary' (HTTP text/*)
49 wakaba 1.8 #ua_field_name => 'user-agent',
50 wakaba 1.21 -ua_use_Config => 1,
51     -ua_use_Win32 => 1,
52 wakaba 1.15 -uri_mailto_safe_level => 4,
53 wakaba 1.14 );
54     sub _init ($;%) {
55     my $self = shift;
56     my %options = @_;
57 wakaba 1.15 $self->{option} = {};
58     my $o = Message::Util::make_clone (\%DEFAULT);
59     for my $name (keys %$o) {
60     if (substr ($name, 0, 1) eq '-') {
61     $self->{option}->{substr ($name, 1)} = $$o{$name};
62     }
63     }
64 wakaba 1.14
65 wakaba 1.8 my @new_fields = ();
66     for my $name (keys %options) {
67     if (substr ($name, 0, 1) eq '-') {
68     $self->{option}->{substr ($name, 1)} = $options{$name};
69 wakaba 1.18 } elsif ($name eq 'entity_header') {
70     $self->{entity_header} = $options{entity_header};
71 wakaba 1.8 } else {
72 wakaba 1.18 push @new_fields, ($name => $options{$name});
73 wakaba 1.8 }
74     }
75 wakaba 1.18
76 wakaba 1.8 my $format = $self->{option}->{format};
77 wakaba 1.14 if ($format =~ /http/) {
78 wakaba 1.15 $self->{option}->{fill_date_ns} = $Message::Header::NS_phname2uri{http};
79     $self->{option}->{fill_msgid_from_ns} = $Message::Header::NS_phname2uri{http};
80     $self->{option}->{fill_ua_ns} = $Message::Header::NS_phname2uri{http};
81     $self->{option}->{accept_coderange} = 'binary';
82 wakaba 1.17 $self->{option}->{text_coderange} = 'binary';
83     $self->{option}->{cte_default} = 'binary';
84 wakaba 1.14 } else {
85 wakaba 1.15 $self->{option}->{fill_date_ns} = $Message::Header::NS_phname2uri{rfc822};
86     $self->{option}->{fill_msgid_from_ns} = $Message::Header::NS_phname2uri{rfc822};
87     $self->{option}->{fill_ua_ns} = $Message::Header::NS_phname2uri{rfc822};
88 wakaba 1.17 $self->{option}->{text_coderange} = '8bit';
89 wakaba 1.15 if ($format =~ /news-usefor|smtp-8bitmime/) {
90     $self->{option}->{accept_coderange} = '8bit';
91 wakaba 1.18 #$self->{option}->{cte_default} = '8bit';
92 wakaba 1.15 } else {
93     $self->{option}->{accept_coderange} = '7bit';
94     }
95 wakaba 1.14 }
96 wakaba 1.15 $self->{option}->{fill_msgid_ns} = $Message::Header::NS_phname2uri{rfc822};
97     $self->{option}->{fill_mimever_ns} = $Message::Header::NS_phname2uri{rfc822};
98 wakaba 1.8 unless (defined $self->{option}->{fill_date}) {
99 wakaba 1.18 $self->{option}->{fill_date} = $format !~ /mime-entity|cgi|uri-url-mailto/;
100 wakaba 1.8 }
101     unless (defined $self->{option}->{fill_msgid}) {
102 wakaba 1.18 $self->{option}->{fill_msgid} = $format !~ /mime-entity|http|uri-url-mailto/;
103 wakaba 1.8 }
104 wakaba 1.15 unless (defined $self->{option}->{fill_ct}) {
105     $self->{option}->{fill_ct} = $format !~ /http/;
106     }
107 wakaba 1.8 unless (defined $self->{option}->{fill_mimever}) {
108 wakaba 1.18 $self->{option}->{fill_mimever} = $format !~ /http|mime-entity/;
109     }
110     unless (defined $self->{option}->{add_ua}) {
111     $self->{option}->{add_ua} = $format !~ /mime-entity/;
112 wakaba 1.8 }
113 wakaba 1.22 unless ($self->{option}->{fill_ua_name}) {
114 wakaba 1.14 $self->{option}->{fill_ua_name} = $format =~ /response|cgi|uri-url-mailto/?
115 wakaba 1.8 'server': 'user-agent';
116     }
117     @new_fields;
118     }
119    
120     =head1 CONSTRUCTORS
121    
122     The following methods construct new C<Message::Entity> objects:
123 wakaba 1.3
124 wakaba 1.8 =over 4
125    
126 wakaba 1.9 =item Message::Entity->new ([%initial-fields/options])
127 wakaba 1.1
128 wakaba 1.9 Constructs a new C<Message::Entity> object. You might pass some initial
129     C<field-name>-C<field-body> pairs and/or options as parameters to the constructor.
130    
131     Example:
132    
133     $msg = new Message::Entity
134     Date => 'Thu, 03 Feb 1994 00:00:00 +0000',
135     Content_Type => 'text/html',
136     X_URI => '<http://www.foo.example/>',
137     -format => 'mail-rfc2822' ## not to be header field
138     ;
139 wakaba 1.1
140     =cut
141    
142     sub new ($;%) {
143     my $class = shift;
144 wakaba 1.8 my $self = bless {}, $class;
145     my %new_field = $self->_init (@_);
146 wakaba 1.22 if (defined $new_field{body}) {
147 wakaba 1.8 $self->{body} = $new_field{body}; $new_field{body} = undef;
148 wakaba 1.18 $self->{body} = $self->_parse_value ([$self->content_type] => $self->{body})
149 wakaba 1.8 if $self->{option}->{parse_all};
150     }
151 wakaba 1.14 $self->{header} = new Message::Header
152     -format => $self->{option}->{format},
153 wakaba 1.22 -header_default_charset => $self->{option}->{header_default_charset},
154     -header_default_charset_input => $self->{option}->{header_default_charset_input},
155 wakaba 1.8 -parse_all => $self->{option}->{parse_all}, %new_field;
156 wakaba 1.1 $self;
157     }
158    
159 wakaba 1.9 =item Message::Entity->parse ($message, [%options])
160 wakaba 1.1
161 wakaba 1.9 Parses given C<message> (a message entity) and constructs a new C<Message::Entity>
162     object. You might pass some additional C<field-name>-C<field-body> pairs
163     or/and initial options as parameters to the constructor.
164 wakaba 1.8
165 wakaba 1.1 =cut
166    
167     sub parse ($$;%) {
168     my $class = shift;
169     my $message = shift;
170 wakaba 1.8 my $self = bless {}, $class;
171     my %new_field = $self->_init (@_);
172 wakaba 1.20 my $nl = "\x0D\x0A";
173     unless ($self->{option}->{strict_linebreak}) {
174 wakaba 1.23 $nl = Message::Util::decide_newline ($message);
175 wakaba 1.20 }
176     my @header = ();
177     my @body = split /$nl/, $message;
178 wakaba 1.8 while (1) {
179     my $line = shift @body;
180     unless (length($line)) {
181     last;
182 wakaba 1.1 } else {
183 wakaba 1.8 push @header, $line;
184 wakaba 1.1 }
185     }
186 wakaba 1.8 $new_field{body} = undef if $new_field{body};
187     $self->{header} = parse_array Message::Header \@header,
188 wakaba 1.22 -header_default_charset => $self->{option}->{header_default_charset},
189     -header_default_charset_input => $self->{option}->{header_default_charset_input},
190 wakaba 1.8 -parse_all => $self->{option}->{parse_all},
191     -format => $self->{option}->{format}, %new_field;
192 wakaba 1.20 $self->{body} = join $nl, @body;
193 wakaba 1.18 $self->{body} = $self->_parse_value ([$self->content_type] => $self->{body})
194 wakaba 1.8 if $self->{option}->{parse_all};
195 wakaba 1.1 $self;
196     }
197    
198 wakaba 1.9 =back
199    
200 wakaba 1.8 =head1 METHODS
201    
202 wakaba 1.1 =head2 $self->header ([$new_header])
203    
204     Returns Message::Header unless $new_header.
205     Set $new_header instead of current C<header>.
206     If !ref $new_header, Message::Header->parse is automatically
207     called.
208    
209     =cut
210    
211 wakaba 1.9 ## TODO: to be compatible with HTTP::Message
212 wakaba 1.1 sub header ($;$) {
213     my $self = shift;
214     my $new_header = shift;
215     if (ref $new_header) {
216     $self->{header} = $new_header;
217     } elsif ($new_header) {
218 wakaba 1.4 $self->{header} = Message::Header->parse ($new_header,
219 wakaba 1.22 -header_default_charset => $self->{option}->{header_default_charset},
220     -header_default_charset_input => $self->{option}->{header_default_charset_input},
221 wakaba 1.8 -parse_all => $self->{option}->{parse_all},
222     -format => $self->{option}->{format});
223 wakaba 1.1 }
224 wakaba 1.14 unless (ref $self->{header} || length $self->{header}) {
225     $self->{header} = new Message::Header (
226 wakaba 1.22 -header_default_charset => $self->{option}->{header_default_charset},
227     -header_default_charset_input => $self->{option}->{header_default_charset_input},
228 wakaba 1.14 -parse_all => $self->{option}->{parse_all},
229     -format => $self->{option}->{format});
230 wakaba 1.2 }
231 wakaba 1.1 $self->{header};
232     }
233    
234     =head2 $self->body ([$new_body])
235    
236     Returns C<body> as string unless $new_body.
237     Set $new_body instead of current C<body>.
238    
239     =cut
240    
241     sub body ($;$) {
242     my $self = shift;
243     my $new_body = shift;
244     if ($new_body) {
245     $self->{body} = $new_body;
246     }
247 wakaba 1.18 $self->{body} = $self->_parse_value ([$self->content_type] => $self->{body})
248 wakaba 1.3 unless ref $self->{body};
249 wakaba 1.1 $self->{body};
250     }
251    
252 wakaba 1.18 ## [SG]et its entity header. This method is or can be used
253     ## when Message::Entity is used as a body (such as message/rfc822).
254     sub entity_header ($;$) {
255     my $self = shift;
256     my $new_header = shift;
257     if (ref $new_header) {
258     $self->{entity_header} = $new_header;
259     }
260     $self->{entity_header};
261     }
262    
263 wakaba 1.14 ## $self->_parse_value ($type, $value);
264     sub _parse_value ($$$) {
265 wakaba 1.3 my $self = shift;
266 wakaba 1.18 my ($mt,$mst) = @{ shift(@_) };
267 wakaba 1.14 my $value = shift;
268     return $value if ref $value;
269    
270     ## decode
271     $value = $self->_decode_body ($value);
272    
273 wakaba 1.18 my $mt_def = $Message::MIME::MediaType::type{$mt}->{$mst};
274     $mt_def = $Message::MIME::MediaType::type{$mt}->{'/default'} unless ref $mt_def;
275     $mt_def = $Message::MIME::MediaType::type{'/default'}->{'/default'}
276     unless ref $mt_def;
277     my $handler = $mt_def->{handler}
278     || $Message::MIME::MediaType::type{$mt}->{'/default'}->{handler}
279     || $Message::MIME::MediaType::type{'/default'}->{'/default'}->{handler};
280     ## Ummmmmm....
281     if (ref $handler eq 'CODE') {
282     $handler = &$handler ($self, $mt, $mst);
283     }
284     my $vtype = $handler->[0];
285     my %vopt = (
286     -format => $self->{option}->{format},
287     -media_type => $mt,
288     -media_subtype => $mst,
289     -parse_all => $self->{option}->{parse_all},
290     -body_default_charset => $self->{option}->{body_default_charset},
291     -body_default_charset_input => $self->{option}->{body_default_charset_input},
292     entity_header => $self->{header},
293     );
294     ## Media type specified option/parameters
295     if (ref $handler->[1] eq 'HASH') {
296     for (keys %{$handler->[1]}) {
297     $vopt{$_} = ${$handler->[1]}{$_};
298     }
299     }
300     ## Inherited options
301     if (ref $handler->[2] eq 'ARRAY') {
302     for (@{$handler->[2]}) {
303     $vopt{'-'.$_} = $self->{option}->{$_};
304     }
305     }
306    
307 wakaba 1.14 if ($vtype eq ':none:') {
308     return $value;
309     } elsif (defined $value) {
310     eval "require $vtype" or Carp::croak qq{<parse>: $vtype: Can't load package: $@};
311 wakaba 1.18 return $vtype->parse ($value, %vopt);
312 wakaba 1.3 } else {
313 wakaba 1.14 eval "require $vtype" or Carp::croak qq{<parse>: $vtype: Can't load package: $@};
314 wakaba 1.18 return $vtype->new (%vopt);
315 wakaba 1.3 }
316     }
317    
318 wakaba 1.14 sub _decode_body ($$) {
319     my $self = shift;
320     my $value = shift;
321     ## MIME CTE
322 wakaba 1.22 my $cte = $self->{_cte} || '';
323 wakaba 1.14 my $ctef = $self->header->field ('content-transfer-encoding',
324     -new_item_unless_exist => 0);
325     $cte = $ctef->value if ref $ctef;
326 wakaba 1.15 my $f = $Message::MIME::Encoding::DECODER{$cte};
327 wakaba 1.14 if (ref $f) {
328     ($value, $cte) = &$f ($self, $value);
329     }
330     $self->{_cte} = $cte;
331     $value;
332     }
333    
334 wakaba 1.15 sub _encode_body ($$\%) {
335 wakaba 1.14 my $self = shift;
336     my $value = shift;
337 wakaba 1.15 my $option = shift;
338 wakaba 1.14 ## MIME CTE
339 wakaba 1.17 my $current_cte = $self->{_cte} || 'binary';
340     my $ctef = $self->{header}->field ('content-transfer-encoding',
341 wakaba 1.14 -new_item_unless_exist => 0);
342 wakaba 1.15 my $cte = ''; $cte = lc $ctef->value if ref $ctef;
343 wakaba 1.16 my %enoption;
344 wakaba 1.15 ## Get media type of entity body and its accept CTE list
345     my ($mt,$mst) = $self->content_type;
346     my $mt_def = $Message::MIME::MediaType::type{$mt}->{$mst};
347     $mt_def = $Message::MIME::MediaType::type{$mt}->{'/default'}
348 wakaba 1.18 unless ref $mt_def;
349 wakaba 1.15 $mt_def = $Message::MIME::MediaType::type{'/default'}->{'/default'}
350     unless ref $mt_def;
351 wakaba 1.16 $enoption{mt_is_text} = 1
352     if $mt eq 'text' || $mt eq 'multipart' || $mt eq 'message';
353 wakaba 1.23 $enoption{mt_is_text} = 1 if $mt_def->{text_content};
354 wakaba 1.16 my ($charset, $charset_def) = '';
355     if ($mt_def->{mime_charset}) {
356     ## If CT is able to have its charset parameter,
357 wakaba 1.17 my $ct = $self->{header}->field ('content-type',
358 wakaba 1.16 -new_item_unless_exist => 0);
359     $charset = $ct->parameter ('charset') if ref $ct;
360     if ($charset) {
361     $charset_def = $Message::MIME::Charset::CHARSET{$charset};
362     } else {
363     $charset_def = $Message::MIME::Charset::CHARSET{'*default'};
364     ## Note: 'encoding_after_encode' option (available for header
365     ## field, but not for message body) is hardcoded.
366     }
367 wakaba 1.18 } else { ## Don't have mime style "charset" parameter
368     $charset_def = {mime_text => 1};
369 wakaba 1.16 }
370     $charset_def = {} unless ref $charset_def; ## dummy
371 wakaba 1.17 if ($charset_def->{mime_text} != 1) {
372 wakaba 1.18 $enoption{mt_is_text} = 0 if $mt eq 'text';
373 wakaba 1.17 my $ct = $self->{header}->field ('content-type');
374     $ct->not_mime_text ($option->{text_coderange} eq 'binary'? 0:1);
375     }
376 wakaba 1.15 ## If accept CTE list is defined,
377 wakaba 1.16 for my $def ($charset_def, $mt_def) {
378     if (ref $def->{accept_cte} eq 'ARRAY') {
379     my $f = 1; for (@{$def->{accept_cte}}) {
380     if ($cte eq $_) {$f = 0; last}
381     }
382     if ($f) { ## If CTE is not accepted,
383     $cte = $def->{accept_cte}->[0];
384     }
385 wakaba 1.15 }
386     }
387     if ($current_cte eq 'binary' || ($current_cte && $current_cte ne $cte)) {
388     my $de = $Message::MIME::Encoding::DECODER{$current_cte};
389     my $en = $Message::MIME::Encoding::ENCODER{$cte || 'binary'};
390     if (ref $de && ref $en) {
391     my ($e, $decoded);
392     ($decoded, $e) = &$de ($self, $value);
393     ## Check transparent coderange
394 wakaba 1.16 my $cr = $self->Message::MIME::Encoding::decide_coderange
395     ($decoded, \%enoption);
396 wakaba 1.15 if ($option->{accept_coderange} eq '8bit') {
397     if ($cr eq 'binary') {
398 wakaba 1.16 $cte = $charset_def->{cte_7bit_preferred}
399     || $mt_def->{cte_7bit_preferred} || 'base64';
400 wakaba 1.15 $en = $Message::MIME::Encoding::ENCODER{$cte};
401     }
402     } elsif ($option->{accept_coderange} eq '7bit') {
403     if ($cr eq 'binary' || $cr eq '8bit') {
404 wakaba 1.16 $cte = $charset_def->{cte_7bit_preferred}
405     || $mt_def->{cte_7bit_preferred} || 'base64';
406 wakaba 1.15 $en = $Message::MIME::Encoding::ENCODER{$cte};
407 wakaba 1.18 if ($mt eq 'message') {
408     my $ct = $self->{header}->field ('content-type');
409     $ct->not_mime_text ($option->{text_coderange} eq 'binary'? 0:1);
410     }
411 wakaba 1.15 }
412     }
413     if ($e eq 'binary') {
414 wakaba 1.16 ($value, $e) = &$en ($self, $decoded, \%enoption);
415 wakaba 1.17 $e = '' if ($e eq $option->{cte_default});
416     $e = '' if $e eq '7bit'
417     && ( $option->{cte_default} eq '8bit'
418     || $option->{cte_default} eq 'binary');
419     $e = '' if $e eq '8bit' && $option->{cte_default} eq 'binary';
420     if ($e) {
421     $ctef = $self->{header}->field ('content-transfer-encoding')
422 wakaba 1.15 unless ref $ctef;
423     $ctef->value ($e);
424 wakaba 1.17 } elsif (ref $ctef) {
425     $ctef->value ('');
426     }
427 wakaba 1.15 } else {
428 wakaba 1.17 $ctef = $self->{header}->field ('content-transfer-encoding')
429 wakaba 1.15 unless ref $ctef;
430     $ctef->value ($current_cte);
431     }
432 wakaba 1.14 } else { ## Can't encode by given CTE
433 wakaba 1.17 $ctef = $self->{header}->field ('content-transfer-encoding')
434 wakaba 1.15 unless ref $ctef;
435 wakaba 1.14 $ctef->value ($current_cte);
436     }
437     }
438 wakaba 1.17 if (ref $ctef && $ctef->value eq '') {
439     $self->{header}->delete ('content-transfer-encoding');
440     }
441 wakaba 1.14 $value;
442     }
443    
444 wakaba 1.1 =head2 $self->stringify ([%option])
445    
446     Returns the C<message> as a string.
447    
448     =cut
449    
450     sub stringify ($;%) {
451     my $self = shift;
452 wakaba 1.8 my %params = @_;
453     my %option = %{$self->{option}};
454     for (grep {/^-/} keys %params) {$option{substr ($_, 1)} = $params{$_}}
455 wakaba 1.18 my ($header, $body, $body0);
456 wakaba 1.14 if (ref $self->{body}) {
457 wakaba 1.18 $self->{body}->entity_header ($self->{header});
458     $body0 = $self->{body}->stringify (-format => $option{format},
459 wakaba 1.14 -linebreak_strict => $option{linebreak_strict});
460     } else {
461 wakaba 1.18 $body0 = $self->{body};
462 wakaba 1.14 }
463 wakaba 1.18 $body = $self->_encode_body ($body0, \%option);
464 wakaba 1.14 if (ref $self->{header}) {
465 wakaba 1.15 my %exist;
466     for ($self->{header}->field_name_list) {$exist{$_} = 1}
467     my $ns_content = $Message::Header::NS_phname2uri{content};
468 wakaba 1.14 if ($option{fill_date}
469     && !$exist{$option{fill_date_name}.':'.$option{fill_date_ns}}) {
470     $self->{header}->field
471     ($option{fill_date_name}, -ns => $option{fill_date_ns})->unix_time (time);
472     }
473     if ($option{fill_msgid}
474     && !$exist{$option{fill_msgid_name}.':'.$option{fill_msgid_ns}}) {
475     my $from = $self->{header}->field
476     ('from', -ns => $option{fill_msgid_from_ns}, -new_item_unless_exist => 0);
477     $from = $from->addr_spec if ref $from;
478     $self->{header}->field
479     ($option{fill_msgid_name}, -ns => $option{fill_msgid_ns})
480     ->generate (addr_spec => $from)
481 wakaba 1.8 if $from;
482 wakaba 1.15 } # fill_msgid
483     my $ismime = 0;
484     for (keys %exist) {if (/:$ns_content$/) { $ismime = 1; last }}
485 wakaba 1.18 unless ($ismime) {
486 wakaba 1.19 $ismime = 1 if $option{force_mime_entity};
487 wakaba 1.18 $ismime = 1 if $option{body_default_media_type} ne 'text';
488     $ismime = 1 if $option{body_default_media_subtype} ne 'plain';
489     }
490 wakaba 1.15 if ($ismime) {
491     if ($option{fill_ct} && !$exist{'type:'.$ns_content}) {
492     my $ct = $self->{header}->field ('type',
493     -parse => 1, -ns => $ns_content);
494 wakaba 1.18 $ct->media_type ($option{body_default_media_type}.'/'
495     .$option{body_default_media_subtype});
496     $ct->replace (Message::MIME::Charset::name_minimumize ($option{body_default_charset} => $body0));
497 wakaba 1.15 }
498     if ($option{fill_mimever}
499     && !$exist{'mime-version:'.$option{fill_mimever_ns}}) {
500     ## BUG: doesn't support rfc10]49, HTTP (ie. non-MIME) content-*: fields
501 wakaba 1.14 $self->{header}->add ('mime-version' => '1.0',
502     -parse => 0, -ns => $option{fill_mimever_ns});
503 wakaba 1.8 }
504 wakaba 1.15 } # $ismime
505 wakaba 1.14 if ($option{format} =~ /uri-url-mailto/ && $exist{'type:$ns_content'}
506 wakaba 1.12 && $option{uri_mailto_safe_level} > 1) {
507     $self->{header}->field ('content-type')->media_type ('text/plain');
508     }
509 wakaba 1.21 if ($option{add_ua}) {
510     $self->{header}->field ($option{fill_ua_name})->add_our_name (
511     -use_Config => $option{ua_use_Config},
512     -use_Win32 => $option{ua_use_Win32},
513     );
514     }
515 wakaba 1.12 $header = $self->{header}->stringify (-format => $option{format},
516     -linebreak_strict => $option{linebreak_strict},
517     -uri_mailto_safe_level => $option{uri_mailto_safe_level});
518 wakaba 1.7 } else {
519     $header = $self->{header};
520 wakaba 1.12 unless ($option{linebreak_strict}) {
521     ## bare \x0D and bare \x0A are unsafe
522     $header =~ s/\x0D(?=[^\x09\x0A\x20])/\x0D\x20/g;
523     $header =~ s/\x0A(?=[^\x09\x20])/\x0A\x20/g;
524     }
525 wakaba 1.7 }
526 wakaba 1.12 if ($option{format} =~ /uri-url-mailto/) {
527 wakaba 1.14 if ($option{format} =~ /rfc1738/) {
528     my $to = $self->{header}->stringify (-format => $option{format},
529     -uri_mailto_safe_level => $option{uri_mailto_safe_level});
530     $to? 'mailto:'.$to: '';
531     } else {
532     my $f = $option{format}; $f =~ s/-mailto/-mailto-to/;
533     my $to = $self->{header}->stringify (-format => $f,
534     -uri_mailto_safe_level => $option{uri_mailto_safe_level});
535     $body =~ s/([^:@+\$A-Za-z0-9\-_.!~*])/sprintf('%%%02X', ord $1)/ge;
536     if (length $body) {
537     $header .= '&' if $header;
538     $header .= 'body='.$body;
539     }
540     $header = '?'.$header if $header;
541     $to||$header? 'mailto:'.$to.$header: '';
542 wakaba 1.12 }
543     } else {
544 wakaba 1.15 $header .= "\x0D\x0A" if $header && $header !~ /\x0D\x0A$/;
545     $header."\x0D\x0A".$body;
546 wakaba 1.12 }
547 wakaba 1.1 }
548 wakaba 1.8 *as_string = \&stringify;
549 wakaba 1.1
550    
551 wakaba 1.9 =head1 SHORTCUT METHOD FOR MESSAGE PROPERTIES
552    
553     =over 4
554    
555     =item $self->content_type ([%options])
556 wakaba 1.1
557 wakaba 1.9 Returns Internet media type of message body
558     (aka MIME type, content type). Only media type
559     (type/subtype pair) is returned, i.e. no parameter
560     is returned, if any. To get such value, or to set
561     new value, use C<field> method.
562 wakaba 1.1
563 wakaba 1.9 Default is C<text/plain>.
564 wakaba 1.3
565 wakaba 1.9 Example:
566 wakaba 1.3
567 wakaba 1.9 $msg->field ('Content-Type')->media_type ('text/html');
568     print $msg->content_type; ## text/html
569 wakaba 1.3
570     =cut
571    
572     sub content_type ($;%) {
573 wakaba 1.8 my $self = shift;
574 wakaba 1.15 my $ct = $self->{header}->field ('content-type', -new_item_unless_exist => 0);
575     unless (ref $ct) {
576 wakaba 1.18 if ($self->{option}->{body_default_media_type} ne 'text'
577     || $self->{option}->{body_default_media_subtype} ne 'plain') {
578     $ct = $self->{header}->field ('content-type');
579     $ct->media_type_major ($self->{option}->{body_default_media_type});
580     $ct->media_type_minor ($self->{option}->{body_default_media_subtype});
581     }
582     return wantarray? ($self->{option}->{body_default_media_type},
583     $self->{option}->{body_default_media_subtype}):
584     $self->{option}->{body_default_media_type}.'/'
585     .$self->{option}->{body_default_media_subtype};
586 wakaba 1.15 }
587     if (wantarray) {
588     ($ct->media_type_major, $ct->media_type_minor);
589     } else {
590     $ct->media_type;
591     }
592 wakaba 1.1 }
593 wakaba 1.15 *media_type = \&content_type;
594 wakaba 1.1
595 wakaba 1.9 =item $self->id
596    
597     Returns ID of message entity. If there are C<Message-ID:>
598     field, its value is returned. Unless, but there are
599     C<Content-ID:> field, it is returned. Without both of
600     fields, C<""> is returned.
601    
602     =cut
603    
604 wakaba 1.5 sub id ($) {
605     my $self = shift;
606     return scalar $self->{header}->field ('message-id')->id
607     if $self->{header}->field_exist ('message-id');
608 wakaba 1.9 return scalar $self->{header}->field ('content-id')->id
609     if $self->{header}->field_exist ('content-id');
610 wakaba 1.8 '';
611 wakaba 1.5 }
612    
613 wakaba 1.9 =back
614    
615     =head1 MISC. METHODS
616    
617     =over 4
618    
619     =item $self->option ( $option-name / $option-name, $option-value, ...)
620    
621     If @_ == 1, returns option value. Else...
622    
623     Set option value. You can pass multiple option name-value pair
624     as parameter. Example:
625    
626     $msg->option (format => 'mail-rfc822',
627     capitalize => 0);
628     print $msg->option ('format'); ## mail-rfc822
629    
630     =cut
631    
632     sub option ($@) {
633     my $self = shift;
634     if (@_ == 1) {
635     return $self->{option}->{ $_[0] };
636     }
637 wakaba 1.18 my %option = @_;
638 wakaba 1.9 while (my ($name, $value) = splice (@_, 0, 2)) {
639     $self->{option}->{$name} = $value;
640     if ($name eq 'format') {
641     $self->header->option (-format => $value);
642     }
643     }
644 wakaba 1.18 if ($option{-recursive}) {
645     $self->{header}->option (%option);
646     $self->{body}->option (%option) if ref $self->{body};
647     }
648 wakaba 1.9 }
649    
650     =item $self->clone ()
651 wakaba 1.8
652     Returns a copy of Message::Entity object.
653    
654     =cut
655    
656     sub clone ($) {
657     my $self = shift;
658     my $clone = new Message::Entity;
659 wakaba 1.14 $clone->{option} = Message::Util::make_clone ($self->{option});
660     for (@{$self->{option}->{_MEMBERS}}) {
661     $clone->{$_} = Message::Util::make_clone ($self->{$_});
662 wakaba 1.8 }
663     $clone;
664     }
665 wakaba 1.5
666 wakaba 1.14 my %_method_default_list = qw(new 1 parse 1 stringify 1 option 1 clone 1 method_available 1);
667     sub method_available ($$) {
668     my $self = shift;
669     my $name = shift;
670     return 1 if $_method_default_list{$name};
671     for (@{$self->{option}->{_METHODS}}) {
672     return 1 if $_ eq $name;
673     }
674     0;
675     }
676    
677 wakaba 1.9 =back
678    
679 wakaba 1.11 =head1 C<format>
680    
681     =over 2
682    
683     =item mail-rfc650
684    
685     Internet mail message, defined by IETF RFC 650
686    
687     =item mail-rfc724
688    
689     Internet mail message, defined by IETF RFC 724
690    
691     =item mail-rfc733
692    
693     Internet mail message, defined by IETF RFC 733
694    
695     =item mail-rfc822
696    
697     Internet mail message, defined by IETF RFC 822
698    
699     =item mail-rfc2822
700    
701     Internet mail message, defined by IETF RFC 2822
702    
703     =item mime-1.0
704    
705     MIME entity
706    
707     =item mime-1.0-rfc1341
708    
709     MIME entity, defined by RFC 1341 (and RFC 1342)
710    
711     =item mime-1.0-rfc1521
712    
713     MIME entity, defined by RFC 1521 and 1522
714    
715     =item mime-1.0-rfc2045
716    
717     MIME entity, defined by RFC 2045,..., 2049
718    
719     =item news-bnews
720    
721     Usenet Bnews format
722    
723     =item news-rfc850
724    
725     Usenet news format, defined by IETF RFC 850
726    
727     =item news-rfc1036
728    
729     Usenet news format, defined by IETF RFC 1036
730    
731     =item news-son-of-rfc1036
732    
733     Usenet news format, defined by son-of-RFC1036
734    
735     =item news-usefor
736    
737     Usenet news format, defined by usefor-article (IETF Internet Draft)
738    
739     =item http-1.0-rfc1945
740    
741     HTTP/1.0 message, defined by IETF RFC 1945
742    
743     =item http-1.0-rfc1945-request
744    
745     HTTP/1.0 request message, defined by IETF RFC 1945
746    
747     =item http-1.0-rfc1945-response
748    
749     HTTP/1.0 response message, defined by IETF RFC 1945
750    
751     =item http-1.1-rfc2068
752    
753     HTTP/1.1 message, defined by IETF RFC 2068
754    
755     =item http-1.1-rfc2068-request
756    
757     HTTP/1.1 request message, defined by IETF RFC 2068
758    
759     =item http-1.1-rfc2068-response
760    
761     HTTP/1.1 response message, defined by IETF RFC 2068
762    
763     =item http-1.1-rfc2616
764    
765     HTTP/1.1 message, defined by IETF RFC 2616
766    
767     =item http-1.1-rfc2616-request
768    
769     HTTP/1.1 request message, defined by IETF RFC 2616
770    
771     =item http-1.1-rfc2616-response
772    
773     HTTP/1.1 response message, defined by IETF RFC 2616
774    
775     =item http-cgi-1.1
776    
777     CGI/1.1 output (for HTTP), defined by coar-cgi-v11 (IETF Internet Draft)
778    
779     =item http-1.0-cgi-1.1
780    
781     CGI/1.1 output (for HTTP/1.0), defined by coar-cgi-v11 (IETF Internet Draft)
782    
783     =item http-1.1-cgi-1.1
784    
785     CGI/1.1 output (for HTTP/1.1), defined by coar-cgi-v11 (IETF Internet Draft)
786    
787     =item http-cgi-1.2
788    
789     CGI/1.2 output, defined by coar-cgi-v12 (to be IETF Internet Draft)
790    
791     =item http-1.0-cgi-1.2
792    
793     CGI/1.2 output (for HTTP/1.0), defined by coar-cgi-v11 (IETF Internet Draft)
794    
795     =item http-1.1-cgi-1.2
796    
797     CGI/1.2 output (for HTTP/1.1), defined by coar-cgi-v11 (IETF Internet Draft)
798    
799     =item http-sip-2.0
800    
801     SIP/2.0 message, defined by IETF RFC 2543
802    
803     =item http-sip-2.0-request
804    
805     SIP/2.0 request message, defined by IETF RFC 2543
806    
807     =item http-sip-2.0-response
808    
809     SIP/2.0 response message, defined by IETF RFC 2543
810    
811     =item http-sip-cgi
812    
813     SIP/2.0 CGI (IETF Internet Draft)
814    
815     =item cpim-1.0
816    
817     CPIM/1.0 (IETF Internet Draft)
818    
819 wakaba 1.12 =item uri-url-mailto-mail-rfc822, uri-url-mailto-mail-rfc2822
820    
821     mailto: URL scheme
822    
823     =item uri-url-mailto-rfc1738
824    
825     mailto: URL scheme (defined by RFC 1738)
826    
827     =item uri-url-mailto-rfc2368, uri-url-mailto-rfc2822
828    
829     mailto: URL scheme (defined by RFC 2368)
830    
831     =item uri-url-mailto-to-mail-rfc822, uri-url-mailto-to-mail-rfc2822
832    
833     C<to> part of mailto: URL scheme (for internal use only)
834    
835 wakaba 1.11 =back
836    
837 wakaba 1.1 =head1 EXAMPLE
838    
839     use Message::Entity;
840 wakaba 1.9 my $msg = new Message::Entity From => '[email protected]',
841     Subject => 'Example message',
842     To => '[email protected]',
843     -format => 'mail-rfc2822',
844     body => $body;
845 wakaba 1.1 $msg->header ($header);
846     $msg->body ($body);
847     print $msg;
848    
849 wakaba 1.3 =head1 SEE ALSO
850    
851     Message::* Perl modules
852     <http://suika.fam.cx/~wakaba/Message-pm/>
853    
854 wakaba 1.1 =head1 LICENSE
855    
856     Copyright 2002 wakaba E<lt>[email protected]<gt>.
857    
858     This program is free software; you can redistribute it and/or modify
859     it under the terms of the GNU General Public License as published by
860     the Free Software Foundation; either version 2 of the License, or
861     (at your option) any later version.
862    
863     This program is distributed in the hope that it will be useful,
864     but WITHOUT ANY WARRANTY; without even the implied warranty of
865     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
866     GNU General Public License for more details.
867    
868     You should have received a copy of the GNU General Public License
869     along with this program; see the file COPYING. If not, write to
870     the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
871     Boston, MA 02111-1307, USA.
872    
873     =head1 CHANGE
874    
875     See F<ChangeLog>.
876 wakaba 1.23 $Date: 2002/06/23 12:20:11 $
877 wakaba 1.1
878     =cut
879    
880     1;

[email protected]
ViewVC Help
Powered by ViewVC 1.1.24