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

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

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.4 by wakaba, Mon Mar 25 10:18:35 2002 UTC revision 1.23 by wakaba, Tue Jul 2 06:37:56 2002 UTC
# Line 12  MIME multipart will be also supported (b Line 12  MIME multipart will be also supported (b
12    
13  package Message::Entity;  package Message::Entity;
14  use strict;  use strict;
15  use vars qw($VERSION %DEFAULT);  use vars qw(%DEFAULT $VERSION);
16  $VERSION=do{my @r=(q$Revision$=~/\d+/g);sprintf "%d."."%02d" x $#r,@r};  $VERSION=do{my @r=(q$Revision$=~/\d+/g);sprintf "%d."."%02d" x $#r,@r};
17    
18  use Message::Header;  require Message::Util;
19  use overload '""' => sub {shift->stringify};  require Message::Header;
20    require Message::MIME::MediaType;
21    require Message::MIME::Encoding;
22    use overload '""' => sub { $_[0]->stringify },
23                 fallback => 1;
24    
25    ## Initialize of this class -- called by constructors
26      %DEFAULT = (
27        -_METHODS   => [qw|header body content_type id|],
28        -_MEMBERS   => [qw|header body _cte|],
29            ## entity_header -- Don't clone.
30        -accept_coderange   => '7bit',      ## 7bit / 8bit / binary
31        #add_ua     => 1,
32        -body_default_charset       => 'iso-2022-int-1',
33        -body_default_charset_input => 'iso-2022-int-1',
34        -body_default_media_type    => 'text',
35        -body_default_media_subtype => 'plain',
36        -cte_default        => '7bit',
37        #fill_date  => 1,
38        -fill_date_name     => 'date',
39        #fill_msgid => 1,
40        -fill_msgid_name    => 'message-id',
41        -force_mime_entity  => 0,
42        -format     => 'mail-rfc2822',
43        -header_default_charset     => 'iso-2022-int-1',
44        -header_default_charset_input       => 'iso-2022-int-1',
45        -linebreak_strict   => 0,   ## BUG: not work perfectly
46        -parse_all  => 0,
47        -text_coderange     => 'binary',
48            ## '8bit' (MIME text/*) / 'binary' (HTTP text/*)
49        #ua_field_name      => 'user-agent',
50        -ua_use_Config      => 1,
51        -ua_use_Win32       => 1,
52        -uri_mailto_safe_level      => 4,
53      );
54    sub _init ($;%) {
55      my $self = shift;
56      my %options = @_;
57      $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      
65      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        } elsif ($name eq 'entity_header') {
70          $self->{entity_header} = $options{entity_header};
71        } else {
72          push @new_fields, ($name => $options{$name});
73        }
74      }
75      
76      my $format = $self->{option}->{format};
77      if ($format =~ /http/) {
78        $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        $self->{option}->{text_coderange} = 'binary';
83        $self->{option}->{cte_default} = 'binary';
84      } else {
85        $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        $self->{option}->{text_coderange} = '8bit';
89        if ($format =~ /news-usefor|smtp-8bitmime/) {
90          $self->{option}->{accept_coderange} = '8bit';
91          #$self->{option}->{cte_default} = '8bit';
92        } else {
93          $self->{option}->{accept_coderange} = '7bit';
94        }
95      }
96      $self->{option}->{fill_msgid_ns}   = $Message::Header::NS_phname2uri{rfc822};
97      $self->{option}->{fill_mimever_ns} = $Message::Header::NS_phname2uri{rfc822};
98      unless (defined $self->{option}->{fill_date}) {
99        $self->{option}->{fill_date} = $format !~ /mime-entity|cgi|uri-url-mailto/;
100      }
101      unless (defined $self->{option}->{fill_msgid}) {
102        $self->{option}->{fill_msgid} = $format !~ /mime-entity|http|uri-url-mailto/;
103      }
104      unless (defined $self->{option}->{fill_ct}) {
105        $self->{option}->{fill_ct} = $format !~ /http/;
106      }
107      unless (defined $self->{option}->{fill_mimever}) {
108        $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      }
113      unless ($self->{option}->{fill_ua_name}) {
114        $self->{option}->{fill_ua_name} = $format =~ /response|cgi|uri-url-mailto/?
115          'server': 'user-agent';
116      }
117      @new_fields;
118    }
119    
120  %DEFAULT = (  =head1 CONSTRUCTORS
   body_class    => {'/DEFAULT' => 'Message::Body::TextPlain'},  
   parse_all     => -1,  
 );  
121    
122  =head2 Message::Entity->new ([%option])  The following methods construct new C<Message::Entity> objects:
123    
124  Returns new Message::Entity instance.  Some options can be  =over 4
125  specified as hash.  
126    =item Message::Entity->new ([%initial-fields/options])
127    
128    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    
140  =cut  =cut
141    
142  sub new ($;%) {  sub new ($;%) {
143    my $class = shift;    my $class = shift;
144    my $self = bless {option => {@_}}, $class;    my $self = bless {}, $class;
145    for (keys %DEFAULT) {$self->{option}->{$_} ||= $DEFAULT{$_}}    my %new_field = $self->_init (@_);
146      if (defined $new_field{body}) {
147        $self->{body} = $new_field{body};  $new_field{body} = undef;
148        $self->{body} = $self->_parse_value ([$self->content_type] => $self->{body})
149          if $self->{option}->{parse_all};
150      }
151      $self->{header} = new Message::Header
152        -format => $self->{option}->{format},
153        -header_default_charset     => $self->{option}->{header_default_charset},
154        -header_default_charset_input       => $self->{option}->{header_default_charset_input},
155        -parse_all => $self->{option}->{parse_all}, %new_field;
156    $self;    $self;
157  }  }
158    
159  =head2 Message::Entity->parse ($message, [%option])  =item Message::Entity->parse ($message, [%options])
160    
161  Parses given C<message> and return a new Message::Entity  Parses given C<message> (a message entity) and constructs a new C<Message::Entity>
162  object.  Some options can be specified as hash.  object.  You might pass some additional C<field-name>-C<field-body> pairs
163    or/and initial options as parameters to the constructor.
164    
165  =cut  =cut
166    
167  sub parse ($$;%) {  sub parse ($$;%) {
168    my $class = shift;    my $class = shift;
169    my $message = shift;    my $message = shift;
170    my $self = bless {option => {@_}}, $class;    my $self = bless {}, $class;
171    for (keys %DEFAULT) {$self->{option}->{$_} ||= $DEFAULT{$_}}    my %new_field = $self->_init (@_);
172    my ($isheader, @header, @body) = 1;    my $nl = "\x0D\x0A";
173    for my $line (split /\x0D?\x0A/, $message) {    unless ($self->{option}->{strict_linebreak}) {
174      if ($isheader && !length($line)) {      $nl = Message::Util::decide_newline ($message);
175        $isheader = 0;    }
176      } elsif ($isheader) {    my @header = ();
177        push @header, $line    my @body = split /$nl/, $message;
178      while (1) {
179        my $line = shift @body;
180        unless (length($line)) {
181          last;
182      } else {      } else {
183        push @body, $line;        push @header, $line;
184      }      }
185    }    }
186    $self->{header} = Message::Header->parse (join ("\n", @header),    $new_field{body} = undef if $new_field{body};
187      parse_all => $self->{option}->{parse_all});    $self->{header} = parse_array Message::Header \@header,
188    $self->{body} = join "\n", @body;      -header_default_charset     => $self->{option}->{header_default_charset},
189    $self->{body} = $self->_body ($self->{body}, $self->content_type)      -header_default_charset_input       => $self->{option}->{header_default_charset_input},
190      if $self->{option}->{parse_all}>0;      -parse_all => $self->{option}->{parse_all},
191        -format => $self->{option}->{format}, %new_field;
192      $self->{body} = join $nl, @body;
193      $self->{body} = $self->_parse_value ([$self->content_type] => $self->{body})
194        if $self->{option}->{parse_all};
195    $self;    $self;
196  }  }
197    
198    =back
199    
200    =head1 METHODS
201    
202  =head2 $self->header ([$new_header])  =head2 $self->header ([$new_header])
203    
204  Returns Message::Header unless $new_header.  Returns Message::Header unless $new_header.
# Line 76  called. Line 208  called.
208    
209  =cut  =cut
210    
211    ## TODO: to be compatible with HTTP::Message
212  sub header ($;$) {  sub header ($;$) {
213    my $self = shift;    my $self = shift;
214    my $new_header = shift;    my $new_header = shift;
# Line 83  sub header ($;$) { Line 216  sub header ($;$) {
216      $self->{header} = $new_header;      $self->{header} = $new_header;
217    } elsif ($new_header) {    } elsif ($new_header) {
218      $self->{header} = Message::Header->parse ($new_header,      $self->{header} = Message::Header->parse ($new_header,
219        parse_all => $self->{option}->{parse_all});      -header_default_charset     => $self->{option}->{header_default_charset},
220        -header_default_charset_input       => $self->{option}->{header_default_charset_input},
221          -parse_all => $self->{option}->{parse_all},
222          -format => $self->{option}->{format});
223    }    }
224    unless ($self->{header}) {    unless (ref $self->{header} || length $self->{header}) {
225      $self->{header} = new Message::Header ();      $self->{header} = new Message::Header (
226        -header_default_charset     => $self->{option}->{header_default_charset},
227        -header_default_charset_input       => $self->{option}->{header_default_charset_input},
228          -parse_all => $self->{option}->{parse_all},
229          -format => $self->{option}->{format});
230    }    }
231    $self->{header};    $self->{header};
232  }  }
# Line 104  sub body ($;$) { Line 244  sub body ($;$) {
244    if ($new_body) {    if ($new_body) {
245      $self->{body} = $new_body;      $self->{body} = $new_body;
246    }    }
247    $self->{body} = $self->_body ($self->{body}, $self->content_type)    $self->{body} = $self->_parse_value ([$self->content_type] => $self->{body})
248      unless ref $self->{body};      unless ref $self->{body};
249    $self->{body};    $self->{body};
250  }  }
251    
252  sub _body ($;$$) {  ## [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;    my $self = shift;
256    my $body = shift;    my $new_header = shift;
257    my $ct = shift;    if (ref $new_header) {
258    $ct = $self->{option}->{body_class}->{$ct}      $self->{entity_header} = $new_header;
259       || $self->{option}->{body_class}->{'/DEFAULT'};    }
260    eval "require $ct";    $self->{entity_header};
261    if (ref $body) {  }
262      return $body;  
263    } elsif ($body) {  ## $self->_parse_value ($type, $value);
264      return $ct->parse ($body,  sub _parse_value ($$$) {
265        parse_all => $self->{option}->{parse_all});    my $self = shift;
266      my ($mt,$mst) = @{ shift(@_) };
267      my $value = shift;
268      return $value if ref $value;
269      
270      ## decode
271      $value = $self->_decode_body ($value);
272      
273      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      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        return $vtype->parse ($value, %vopt);
312    } else {    } else {
313      return $ct->new ($body);      eval "require $vtype" or Carp::croak qq{<parse>: $vtype: Can't load package: $@};
314        return $vtype->new (%vopt);
315    }    }
316  }  }
317    
318    sub _decode_body ($$) {
319      my $self = shift;
320      my $value = shift;
321      ## MIME CTE
322            my $cte = $self->{_cte} || '';
323            my $ctef = $self->header->field ('content-transfer-encoding',
324                                          -new_item_unless_exist => 0);
325            $cte = $ctef->value if ref $ctef;
326            my $f = $Message::MIME::Encoding::DECODER{$cte};
327            if (ref $f) {
328              ($value, $cte) = &$f ($self, $value);
329            }
330            $self->{_cte} = $cte;
331      $value;
332    }
333    
334    sub _encode_body ($$\%) {
335      my $self = shift;
336      my $value = shift;
337      my $option = shift;
338      ## MIME CTE
339            my $current_cte = $self->{_cte} || 'binary';
340            my $ctef = $self->{header}->field ('content-transfer-encoding',
341                                          -new_item_unless_exist => 0);
342            my $cte = ''; $cte = lc $ctef->value if ref $ctef;
343            my %enoption;
344            ## 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                unless ref $mt_def;
349              $mt_def = $Message::MIME::MediaType::type{'/default'}->{'/default'}
350                unless ref $mt_def;
351              $enoption{mt_is_text} = 1
352                if $mt eq 'text' || $mt eq 'multipart' || $mt eq 'message';
353              $enoption{mt_is_text} = 1 if $mt_def->{text_content};
354              my ($charset, $charset_def) = '';
355              if ($mt_def->{mime_charset}) {
356              ## If CT is able to have its charset parameter,
357                my $ct = $self->{header}->field ('content-type',
358                                               -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              } else {      ## Don't have mime style "charset" parameter
368                $charset_def = {mime_text => 1};
369              }
370              $charset_def = {} unless ref $charset_def;    ## dummy
371              if ($charset_def->{mime_text} != 1) {
372                $enoption{mt_is_text} = 0 if $mt eq 'text';
373                my $ct = $self->{header}->field ('content-type');
374                $ct->not_mime_text ($option->{text_coderange} eq 'binary'? 0:1);
375              }
376            ## If accept CTE list is defined,
377            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              }
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                  my $cr = $self->Message::MIME::Encoding::decide_coderange
395                    ($decoded, \%enoption);
396                  if ($option->{accept_coderange} eq '8bit') {
397                    if ($cr eq 'binary') {
398                      $cte = $charset_def->{cte_7bit_preferred}
399                          || $mt_def->{cte_7bit_preferred} || 'base64';
400                      $en = $Message::MIME::Encoding::ENCODER{$cte};
401                    }
402                  } elsif ($option->{accept_coderange} eq '7bit') {
403                    if ($cr eq 'binary' || $cr eq '8bit') {
404                      $cte = $charset_def->{cte_7bit_preferred}
405                          || $mt_def->{cte_7bit_preferred} || 'base64';
406                      $en = $Message::MIME::Encoding::ENCODER{$cte};
407                      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                    }
412                  }
413                if ($e eq 'binary') {
414                  ($value, $e) = &$en ($self, $decoded, \%enoption);
415                  $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                       unless ref $ctef;
423                    $ctef->value ($e);
424                  } elsif (ref $ctef) {
425                    $ctef->value ('');
426                  }
427                } else {
428                  $ctef = $self->{header}->field ('content-transfer-encoding')
429                     unless ref $ctef;
430                  $ctef->value ($current_cte);
431                }
432              } else {      ## Can't encode by given CTE
433                $ctef = $self->{header}->field ('content-transfer-encoding')
434                   unless ref $ctef;
435                $ctef->value ($current_cte);
436              }
437            }
438            if (ref $ctef && $ctef->value eq '') {
439              $self->{header}->delete ('content-transfer-encoding');
440            }
441      $value;
442    }
443    
444  =head2 $self->stringify ([%option])  =head2 $self->stringify ([%option])
445    
446  Returns the C<message> as a string.  Returns the C<message> as a string.
# Line 134  Returns the C<message> as a string. Line 449  Returns the C<message> as a string.
449    
450  sub stringify ($;%) {  sub stringify ($;%) {
451    my $self = shift;    my $self = shift;
452    my %OPT = @_;    my %params = @_;
453    my ($header, $body) = ($self->{header}, $self->{body});    my %option = %{$self->{option}};
454    $header .= "\n" if $header && $header !~ /\n$/;    for (grep {/^-/} keys %params) {$option{substr ($_, 1)} = $params{$_}}
455    $header."\n".$body;    my ($header, $body, $body0);
456      if (ref $self->{body}) {
457        $self->{body}->entity_header ($self->{header});
458        $body0 = $self->{body}->stringify (-format => $option{format},
459          -linebreak_strict => $option{linebreak_strict});
460      } else {
461        $body0 = $self->{body};
462      }
463      $body = $self->_encode_body ($body0, \%option);
464      if (ref $self->{header}) {
465        my %exist;
466        for ($self->{header}->field_name_list) {$exist{$_} = 1}
467        my $ns_content = $Message::Header::NS_phname2uri{content};
468        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            if $from;
482        }   # fill_msgid
483        my $ismime = 0;
484        for (keys %exist) {if (/:$ns_content$/) { $ismime = 1; last }}
485        unless ($ismime) {
486          $ismime = 1 if $option{force_mime_entity};
487          $ismime = 1 if $option{body_default_media_type} ne 'text';
488          $ismime = 1 if $option{body_default_media_subtype} ne 'plain';
489        }
490        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              $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          }
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            $self->{header}->add ('mime-version' => '1.0',
502              -parse => 0, -ns => $option{fill_mimever_ns});
503          }
504        }   # $ismime
505        if ($option{format} =~ /uri-url-mailto/ && $exist{'type:$ns_content'}
506         && $option{uri_mailto_safe_level} > 1) {
507          $self->{header}->field ('content-type')->media_type ('text/plain');
508        }
509        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        $header = $self->{header}->stringify (-format => $option{format},
516          -linebreak_strict => $option{linebreak_strict},
517          -uri_mailto_safe_level => $option{uri_mailto_safe_level});
518      } else {
519        $header = $self->{header};
520        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      }
526      if ($option{format} =~ /uri-url-mailto/) {
527        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        }
543      } else {
544        $header .= "\x0D\x0A" if $header && $header !~ /\x0D\x0A$/;
545        $header."\x0D\x0A".$body;
546      }
547  }  }
548  sub as_string ($;%) {shift->stringify}  *as_string = \&stringify;
549    
 =head2 $self->option ($option_name)  
550    
551  Returns/set (new) value of the option.  =head1 SHORTCUT METHOD FOR MESSAGE PROPERTIES
552    
553    =over 4
554    
555    =item $self->content_type ([%options])
556    
557    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    
563    Default is C<text/plain>.
564    
565    Example:
566    
567      $msg->field ('Content-Type')->media_type ('text/html');
568      print $msg->content_type;     ## text/html
569    
570  =cut  =cut
571    
572  sub option ($$;$) {  sub content_type ($;%) {
573    my $self = shift;    my $self = shift;
574    my ($name, $newval) = @_;    my $ct = $self->{header}->field ('content-type', -new_item_unless_exist => 0);
575    if ($newval) {    unless (ref $ct) {
576      $self->{option}->{$name} = $newval;      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      }
587      if (wantarray) {
588        ($ct->media_type_major, $ct->media_type_minor);
589      } else {
590        $ct->media_type;
591    }    }
   $self->{option}->{$name};  
592  }  }
593    *media_type = \&content_type;
594    
595  =head2 $self->content_type ([%options])  =item $self->id
596    
597  Returns C<body>'s content-type (Internet Media Type).  Returns ID of message entity.  If there are C<Message-ID:>
598  This method is not implemented yet so always returns  field, its value is returned.  Unless, but there are
599  C<text/plain>.  C<Content-ID:> field, it is returned.  Without both of
600    fields, C<""> is returned.
601    
602  =cut  =cut
603    
604  sub content_type ($;%) {  sub id ($) {
605    'text/plain';    my $self = shift;
606      return scalar $self->{header}->field ('message-id')->id
607        if $self->{header}->field_exist ('message-id');
608      return scalar $self->{header}->field ('content-id')->id
609        if $self->{header}->field_exist ('content-id');
610      '';
611    }
612    
613    =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      my %option = @_;
638      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      if ($option{-recursive}) {
645        $self->{header}->option (%option);
646        $self->{body}->option (%option) if ref $self->{body};
647      }
648  }  }
649    
650    =item $self->clone ()
651    
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      $clone->{option} = Message::Util::make_clone ($self->{option});
660      for (@{$self->{option}->{_MEMBERS}}) {
661        $clone->{$_} = Message::Util::make_clone ($self->{$_});
662      }
663      $clone;
664    }
665    
666    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    =back
678    
679    =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    =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    =back
836    
837  =head1 EXAMPLE  =head1 EXAMPLE
838    
839    use Message::Entity;    use Message::Entity;
840    my $msg = new Message::Entity;    my $msg = new Message::Entity From    => '[email protected]',
841                                    Subject => 'Example message',
842                                    To      => '[email protected]',
843                                    -format => 'mail-rfc2822',
844                                    body    => $body;
845    $msg->header ($header);    $msg->header ($header);
846    $msg->body ($body);    $msg->body ($body);
847    print $msg;    print $msg;
Legend:
Removed from v.1.4  
changed lines
  Added in v.1.23
[email protected]
 ViewVC Help
Powered by ViewVC 1.1.24