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