/[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.26 by wakaba, Mon Jul 8 12:39:39 2002 UTC revision 1.39 by wakaba, Sat Dec 28 09:10:16 2002 UTC
# Line 10  MIME multipart will be also supported (b Line 10  MIME multipart will be also supported (b
10    
11  =cut  =cut
12    
13    require 5.6.0;  ## (require: v5.6.0 data type)
14  package Message::Entity;  package Message::Entity;
15  use strict;  use strict;
16  use vars qw(%DEFAULT $VERSION);  use vars qw(%DEFAULT %REG $VERSION);
17  $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};
18    
19  require Message::Util;  require Message::Util;
# Line 21  require Message::MIME::MediaType; Line 22  require Message::MIME::MediaType;
22  require Message::MIME::Encoding;  require Message::MIME::Encoding;
23  use overload '""' => sub { $_[0]->stringify },  use overload '""' => sub { $_[0]->stringify },
24               fallback => 1;               fallback => 1;
25    *REG = \%Message::Util::REG;
26    
27  ## Initialize of this class -- called by constructors  ## Initialize of this class -- called by constructors
28    %DEFAULT = (    %DEFAULT = (
# Line 28  use overload '""' => sub { $_[0]->string Line 30  use overload '""' => sub { $_[0]->string
30      -_MEMBERS   => [qw|header body _cte|],      -_MEMBERS   => [qw|header body _cte|],
31          ## entity_header -- Don't clone.          ## entity_header -- Don't clone.
32      -accept_coderange   => '7bit',      ## 7bit / 8bit / binary      -accept_coderange   => '7bit',      ## 7bit / 8bit / binary
     #add_ua     => 1,  
33      -body_default_charset       => 'iso-2022-int-1',      -body_default_charset       => 'iso-2022-int-1',
34      -body_default_charset_input => 'iso-2022-int-1',      -body_default_charset_input => 'iso-2022-int-1',
35      -body_default_media_type    => 'text',      -body_default_media_type    => 'text',
36      -body_default_media_subtype => 'plain',      -body_default_media_subtype => 'plain',
37      -cte_default        => '7bit',      -cte_default        => '7bit',
38      #fill_date  => 1,      -fill_missing_fields        => 1,
39      -fill_date_name     => 'date',          #add_ua => 1,
40      -fill_md5   => 0,          #fill_date      => 1,
41      -fill_md5_name      => 'md5',          -fill_date_name => 'date',
42      #fill_msgid => 1,          -fill_destination       => 0,
43      -fill_msgid_name    => 'message-id',          #fill_destination_ns
44            #fill_destination_resent_ns
45            #fill_from_ns
46            -fill_md5       => 0,
47            -fill_md5_name  => 'md5',
48            #fill_msgid     => 1,
49            -fill_msgid_name        => 'message-id',
50            #fill_sender_ns
51            -fill_source    => 0,
52            -recalc_md5     => 1,
53      -force_mime_entity  => 0,      -force_mime_entity  => 0,
54      -format     => 'mail-rfc2822',      -format     => 'mail-rfc2822',
55        -guess_media_type   => 1,
56        #internal_charset_name
57      -header_default_charset     => 'iso-2022-int-1',      -header_default_charset     => 'iso-2022-int-1',
58      -header_default_charset_input       => 'iso-2022-int-1',      -header_default_charset_input       => 'iso-2022-int-1',
     -hook_init_fill_options     => sub {},  
     -hook_stringify_fill_fields => sub {},  
59      -linebreak_strict   => 0,   ## BUG: not work perfectly      -linebreak_strict   => 0,   ## BUG: not work perfectly
60        -output_magic_line  => 1,
61      -parse_all  => 0,      -parse_all  => 0,
62      -recalc_md5 => 1,      -remove_post_newline        => 0,
63        -remove_pre_newline => 0,
64      -text_coderange     => 'binary',      -text_coderange     => 'binary',
65          ## '8bit' (MIME text/*) / 'binary' (HTTP text/*)          ## '8bit' (MIME text/*) / 'binary' (HTTP text/*)
66      #ua_field_name      => 'user-agent',      #ua_field_name      => 'user-agent',
67      -ua_use_Config      => 1,      -ua_use_Config      => 1,
68      -ua_use_Win32       => 1,      -ua_use_Win32       => 1,
69      -uri_mailto_safe_level      => 4,      -uri_mailto_safe_level      => 4,
70        -use_magic_line     => 1,
71    );    );
72  sub _init ($;%) {  sub _init ($;%) {
73    my $self = shift;    my $self = shift;
# Line 79  sub _init ($;%) { Line 92  sub _init ($;%) {
92    }    }
93        
94    my $format = $self->{option}->{format};    my $format = $self->{option}->{format};
95      my $ns822 = $Message::Header::NS_phname2uri{'x-rfc822'};
96      my $nshttp = $Message::Header::NS_phname2uri{'x-http'};
97    if ($format =~ /http/) {    if ($format =~ /http/) {
98      $self->{option}->{fill_date_ns}       = $Message::Header::NS_phname2uri{'x-http'};      $self->{option}->{fill_date_ns} = $nshttp unless defined $options{-fill_date_ns};
99      $self->{option}->{fill_msgid_from_ns} = $Message::Header::NS_phname2uri{'x-http'};      $self->{option}->{fill_from_ns} = $nshttp unless defined $options{-fill_from_ns};
100      $self->{option}->{fill_ua_ns}         = $Message::Header::NS_phname2uri{'x-http'};      $self->{option}->{fill_ua_ns}   = $nshttp unless defined $options{-fill_ua_ns};
101        $self->{option}->{fill_source} = 0 unless defined $options{-fill_source};
102      $self->{option}->{accept_coderange} = 'binary';      $self->{option}->{accept_coderange} = 'binary';
103      $self->{option}->{text_coderange} = 'binary';      $self->{option}->{text_coderange} = 'binary';
104      $self->{option}->{cte_default} = 'binary';      $self->{option}->{cte_default} = 'binary';
105    } else {    } else {
106      $self->{option}->{fill_date_ns}       = $Message::Header::NS_phname2uri{'x-rfc822'};      if ($format =~ /mail-rfc822|mail-rfc2822/ && $format !~ /mime-entity/) {
107      $self->{option}->{fill_msgid_from_ns} = $Message::Header::NS_phname2uri{'x-rfc822'};        $self->{option}->{fill_destination} = 1;
108      $self->{option}->{fill_ua_ns}         = $Message::Header::NS_phname2uri{'x-rfc822'};        $self->{option}->{fill_source} = 1 unless defined $options{-fill_source};
109        }
110        $self->{option}->{fill_date_ns} = $ns822 unless defined $options{-fill_date_ns};
111        $self->{option}->{fill_from_ns} = $ns822 unless defined $options{-fill_from_ns};
112        $self->{option}->{fill_ua_ns}   = $ns822 unless defined $options{-fill_ua_ns};
113      $self->{option}->{text_coderange} = '8bit';      $self->{option}->{text_coderange} = '8bit';
114      if ($format =~ /news-usefor|smtp-8bitmime/) {      if ($format =~ /news-usefor|smtp-8bitmime/) {
115        $self->{option}->{accept_coderange} = '8bit';        $self->{option}->{accept_coderange} = '8bit';
       #$self->{option}->{cte_default} = '8bit';  
116      } else {      } else {
117        $self->{option}->{accept_coderange} = '7bit';        $self->{option}->{accept_coderange} = '7bit';
118      }      }
119    }    }
120    $self->{option}->{fill_msgid_ns}   = $Message::Header::NS_phname2uri{'x-rfc822'};    for (qw/fill_msgid_ns fill_msgid_from fill_mimever_ns fill_destination_ns fill_sender_ns/) {
121    $self->{option}->{fill_mimever_ns} = $Message::Header::NS_phname2uri{'x-rfc822'};      $self->{option}->{$_} = $ns822;
122      }
123      $self->{option}->{fill_destination_resent_ns} = $Message::Header::NS_phname2uri{'x-rfc822-resent'};
124    unless (defined $self->{option}->{fill_date}) {    unless (defined $self->{option}->{fill_date}) {
125      $self->{option}->{fill_date} = $format !~ /mime-entity|cgi|uri-url-mailto/;      $self->{option}->{fill_date} = $format !~ /mime-entity|cgi|uri-url-mailto/;
126    }    }
# Line 119  sub _init ($;%) { Line 140  sub _init ($;%) {
140      $self->{option}->{fill_ua_name} = $format =~ /response|cgi|uri-url-mailto/?      $self->{option}->{fill_ua_name} = $format =~ /response|cgi|uri-url-mailto/?
141        'server': 'user-agent';        'server': 'user-agent';
142    }    }
143    &{ $self->{option}->{hook_init_fill_options} } ($self, $self->{option});    unless (defined $options{-output_magic_line}) {
144        $self->{option}->{output_magic_line} = 0
145          if $format =~ /mail|news|mime/;
146      }
147    @new_fields;    @new_fields;
148  }  }
149    
# Line 137  C<field-name>-C<field-body> pairs and/or Line 161  C<field-name>-C<field-body> pairs and/or
161  Example:  Example:
162    
163   $msg = new Message::Entity   $msg = new Message::Entity
         Date         => 'Thu, 03 Feb 1994 00:00:00 +0000',  
164          Content_Type => 'text/html',          Content_Type => 'text/html',
165          X_URI => '<http://www.foo.example/>',          X_URI => '<http://www.foo.example/>',
166          -format => 'mail-rfc2822'       ## not to be header field          -format => 'mail-rfc2822'       ## not to be header field
# Line 179  sub parse ($$;%) { Line 202  sub parse ($$;%) {
202    unless ($self->{option}->{linebreak_strict}) {    unless ($self->{option}->{linebreak_strict}) {
203      $nl = Message::Util::decide_newline ($message);      $nl = Message::Util::decide_newline ($message);
204    }    }
205    ## BUG: binary unsafe yet!    my ($hdr, $body);
206    my @header = ();    $message =~ s/^(?:$nl)+//s if $self->{option}->{remove_pre_newline};
207    my @body = split /$nl/, $message;    $message =~ s/(?:$nl)+$/$nl/s if $self->{option}->{remove_post_newline};
208    while (1) {    if ($self->{option}->{use_magic_line}) {
209      my $line = shift @body;      ## TODO: Reset format option?
210      unless (length($line)) {      if ($message =~ s/>?From (.+?)$nl//gs) {    ## Mail from line
211        last;        $new_field{'x-rfc822-mail-from'} = $1;
212      } else {      } elsif ($message =~ s#^($REG{http_token})\x20($REG{S_uri})\x20($REG{http_token})/([0-9]+)\.([0-9]+)$nl##gs) {
213        push @header, $line;      ## HTTP Request
214          ($self->{http_method}, $self->{http_request_uri},
215          $self->{http_protocol_name}, $self->{http_protocol_version})
216            = ($1, $2, uc $3, pack ('U2', $4, $5));
217        } elsif ($message =~ s#^($REG{http_token})/([0-9]+)\.([0-9]+)\x20([0-9][0-9][0-9]\x20.*?)$nl##gs) {
218        ## HTTP Response
219          ($self->{http_protocol_name}, $self->{http_protocol_version})
220            = (uc $1, pack ('U2', $2, $3));
221          $new_field{'x-http-status'} = $4;
222        } elsif ($message =~ s#^($REG{http_token})\x20($REG{S_uri})$nl##gs) {
223        ## HTTP/0.9 simple-request
224          ($self->{http_method}, $self->{http_request_uri},
225          $self->{http_protocol_name}, $self->{http_protocol_version})
226            = ($1, $2, 'HTTP', v0.9);
227          $message = $nl . $message;        ## Has no header fields
228      }      }
229    }    }
230      if ($message !~ s/^$nl//s) {
231        ($hdr, $body) = split /$nl$nl/, $message, 2;
232      } else {
233        $hdr = ''; $body = $message;
234        $body =~ s/^$nl//s;
235      }
236    $new_field{body} = undef if $new_field{body};    $new_field{body} = undef if $new_field{body};
237    $self->{header} = parse_array Message::Header \@header,          ## Is this implemention good?
238      $self->{header} = parse Message::Header $hdr,
239      -header_default_charset     => $self->{option}->{header_default_charset},      -header_default_charset     => $self->{option}->{header_default_charset},
240      -header_default_charset_input       => $self->{option}->{header_default_charset_input},      -header_default_charset_input       => $self->{option}->{header_default_charset_input},
241      -parse_all => $self->{option}->{parse_all},      -parse_all => $self->{option}->{parse_all},
242      -format => $self->{option}->{format}, %new_field;      -format => $self->{option}->{format},
243    $self->{body} = join ($nl, @body) . $nl;      %new_field; ## Additional header fields
244    $self->{body} = $self->_parse_value ([$self->content_type] => $self->{body})    
245      $self->{body} = $body;
246      $self->{body} = $self->_parse_value ([ $self->content_type ] => $self->{body})
247      if $self->{option}->{parse_all};      if $self->{option}->{parse_all};
248    $self;    $self;
249  }  }
# Line 279  sub md5_check ($) { Line 325  sub md5_check ($) {
325    }    }
326    my $MD5;    my $MD5;
327    eval q{    eval q{
328          require Digest::MD5;  require MIME::Base64;      require Digest::MD5;
329          $MD5 = MIME::Base64::encode (Digest::MD5::md5 ($self->{body}));      $MD5 = ($self->Message::MIME::Encoding::encode_base64 (Digest::MD5::md5 ($self->{body})))[0];
330          $MD5 =~ tr/\x09\x0A\x0D\x20//d;      $MD5 =~ tr/\x09\x0A\x0D\x20//d;
331    } or Carp::croak $@;    1} or Carp::croak $@;
332    return $MD5 eq $md5? 1 : 0;    return $MD5 eq $md5? 1 : 0;
333  }  }
334    
# Line 316  sub _parse_value ($$$) { Line 362  sub _parse_value ($$$) {
362      -parse_all  => $self->{option}->{parse_all},      -parse_all  => $self->{option}->{parse_all},
363      -body_default_charset       => $self->{option}->{body_default_charset},      -body_default_charset       => $self->{option}->{body_default_charset},
364      -body_default_charset_input => $self->{option}->{body_default_charset_input},      -body_default_charset_input => $self->{option}->{body_default_charset_input},
365        -internal_charset_name      => $self->{option}->{internal_charset_name},
366      entity_header       => $self->{header},      entity_header       => $self->{header},
367    );    );
368    ## Media type specified option/parameters    ## Media type specified option/parameters
# Line 388  sub _encode_body ($$\%) { Line 435  sub _encode_body ($$\%) {
435                $charset_def = $Message::MIME::Charset::CHARSET{$charset};                $charset_def = $Message::MIME::Charset::CHARSET{$charset};
436              } else {              } else {
437                $charset_def = $Message::MIME::Charset::CHARSET{'*default'};                $charset_def = $Message::MIME::Charset::CHARSET{'*default'};
438                ## Note: 'encoding_after_encode' option (available for header                ## Note: 'encoding_after_encode' option's value is hardcoded.
               ## field, but not for message body) is hardcoded.  
439              }              }
440            } else {      ## Don't have mime style "charset" parameter            } else {      ## Don't have mime style "charset" parameter
441              $charset_def = {mime_text => 1};              $charset_def = {mime_text => 1};
442            }            }
443            $charset_def = {} unless ref $charset_def;    ## dummy            $charset_def = {} unless ref $charset_def;    ## dummy
444            if ($charset_def->{mime_text} != 1) {            #if ($charset_def->{mime_text} != 1) {        ## See also Note above
445              if (Message::MIME::Charset::is_mime_text ($charset || '*default') != 1) {
446              $enoption{mt_is_text} = 0 if $mt eq 'text';              $enoption{mt_is_text} = 0 if $mt eq 'text';
447              my $ct = $self->{header}->field ('content-type');              my $ct = $self->{header}->field ('content-type');
448              $ct->not_mime_text ($option->{text_coderange} eq 'binary'? 0:1);              $ct->not_mime_text ($option->{text_coderange} eq 'binary'? 0:1);
# Line 482  sub stringify ($;%) { Line 529  sub stringify ($;%) {
529    my ($header, $body, $body0);    my ($header, $body, $body0);
530    if (ref $self->{body}) {    if (ref $self->{body}) {
531      $self->{body}->entity_header ($self->{header});      $self->{body}->entity_header ($self->{header});
532      $body0 = $self->{body}->stringify (-format => $option{format},      $body0 = $self->{body}->stringify (-parent_format => $option{format},
533        -linebreak_strict => $option{linebreak_strict});        -linebreak_strict => $option{linebreak_strict});
534    } else {    } else {
535      $body0 = $self->{body};      $body0 = $self->{body};
536    }    }
537    $body = $self->_encode_body ($body0, \%option);    $body = $self->_encode_body ($body0, \%option);
538    if (ref $self->{header}) {    if (ref $self->{header}) {
     my %exist;  
     for ($self->{header}->field_name_list) {$exist{$_} = 1}  
     &{ $option{hook_stringify_fill_fields} } ($self, \%exist, \%option);  
539      my $ns_content = $Message::Header::NS_phname2uri{content};      my $ns_content = $Message::Header::NS_phname2uri{content};
540      if ($option{fill_date}      my $filler;
541         && !$exist{$option{fill_date_name}.':'.$option{fill_date_ns}}) {      $filler = sub {
542        $self->{header}->field        my ($hdr, $exist, $hdr_option) = @_;
543          ($option{fill_date_name}, -ns => $option{fill_date_ns})->unix_time (time);        ## Date: (RFC 822, HTTP)
544      }        if ($option{fill_date}
545      if ($option{fill_msgid}           && !$exist->{$option{fill_date_name}.':'.$option{fill_date_ns}}) {
546         && !$exist{$option{fill_msgid_name}.':'.$option{fill_msgid_ns}}) {          $hdr->field
547        my $from = $self->{header}->field            ($option{fill_date_name}, -ns => $option{fill_date_ns})->unix_time (time);
         ('from', -ns => $option{fill_msgid_from_ns}, -new_item_unless_exist => 0);  
       $from = $from->addr_spec if ref $from;  
       $self->{header}->field  
         ($option{fill_msgid_name}, -ns => $option{fill_msgid_ns})  
         ->generate (addr_spec => $from)  
         if $from;  
     }   # fill_msgid  
     if (($option{fill_md5} && !$exist{ $option{fill_md5_name} .':'. $ns_content})  
      || ($option{recalc_md5} && $exist{ $option{fill_md5_name} .':'. $ns_content})) {  
       my $md5;  
       eval q{  
         require Digest::MD5;  require MIME::Base64;  
         $md5 = MIME::Base64::encode (Digest::MD5::md5 ($body0));  
         $md5 =~ tr/\x09\x0A\x0D\x20//d;  
       } or Carp::carp $@;  
       if ($md5) {  
         my $md5f = $self->{header}->field ($option{fill_md5_name}, -ns => $ns_content);  
         $md5f->value ($md5);  
548        }        }
549      }        ## Message-ID: (RFC 822)
550      my $ismime = 0;        if ($option{fill_msgid}
551      for (keys %exist) {if (/:$ns_content$/) { $ismime = 1; last }}           && !$exist->{$option{fill_msgid_name}.':'.$option{fill_msgid_ns}}) {
552      unless ($ismime) {          my $from = $hdr->field
553        $ismime = 1 if $option{force_mime_entity};            ('from', -ns => $option{fill_msgid_from_ns}, -new_item_unless_exist => 0);
554        $ismime = 1 if $option{fill_md5};          $from = $from->addr_spec if ref $from;
555        $ismime = 1 if $option{body_default_media_type} ne 'text';          $hdr->field ($option{fill_msgid_name}, -ns => $option{fill_msgid_ns})
556        $ismime = 1 if $option{body_default_media_subtype} ne 'plain';              ->generate (addr_spec => $from) if $from;
557      }        } # fill_msgid
558      if ($ismime) {        ## To:, CC:, BCC:, Resent-To:, Resent-Cc:, Resent-Bcc: (RFC 822)
559        if ($option{fill_ct} && !$exist{'type:'.$ns_content}) {        if ($option{fill_destination}) {
560            my $ct = $self->{header}->field ('type',          if ( !$exist->{ 'to:'.$option{fill_destination_ns} }
561              -parse => 1, -ns => $ns_content);            && !$exist->{ 'cc:'.$option{fill_destination_ns} }
562            $ct->media_type ($option{body_default_media_type}.'/'            && !$exist->{ 'bcc:'.$option{fill_destination_ns} }
563                            .$option{body_default_media_subtype});            && !$exist->{ 'to:'.$option{fill_destination_resent_ns} }
564            $ct->replace (Message::MIME::Charset::name_minimumize ($option{body_default_charset} => $body0));            && !$exist->{ 'cc:'.$option{fill_destination_resent_ns} }
565              && !$exist->{ 'bcc:'.$option{fill_destination_resent_ns} } ) {
566              $hdr->add (bcc => '');
567            }
568          }
569          ## From:, Sender:
570          if ($option{fill_source}) {
571            ## From:
572            if (!$exist->{ 'from:'.$option{fill_from_ns} }) {
573              $hdr->add (from => 'Unknown source <[email protected]>',
574                         -ns => $option{fill_from_ns});
575            ## From: exists, Sender: not exist
576            } elsif (!$exist->{ 'sender:'.$option{fill_sender_ns} }) {
577              my $from = $hdr->field ('from', -ns => $option{fill_from_ns});
578              if ($from->count > 1) {
579                $hdr->field ('sender', -ns => $option{fill_sender_ns})
580                    ->add ($from->item (0, -by => 'index'));
581              }
582            }
583          }
584          ## Content-MD5:
585          if (($option{fill_md5} && !$exist->{ $option{fill_md5_name} .':'. $ns_content})
586            || ($option{recalc_md5} && $exist->{ $option{fill_md5_name} .':'. $ns_content})) {
587            my $md5;
588            eval q{
589              require Digest::MD5;
590              $md5 = ($self->Message::MIME::Encoding::encode_base64 (Digest::MD5::md5 ($body0)))[0];
591              $md5 =~ tr/\x09\x0A\x0D\x20//d;
592            1} or Carp::carp $@;
593            if ($md5) {
594              my $md5f = $hdr->field ($option{fill_md5_name}, -ns => $ns_content);
595              $md5f->value ($md5);
596            }
597        }        }
598        if ($option{fill_mimever}        my $ismime = 0;
599            && !$exist{'mime-version:'.$option{fill_mimever_ns}}) {        for (keys %$exist) {if (/:$ns_content$/) { $ismime = 1; last }}
600          ## BUG: doesn't support rfc10]49, HTTP (ie. non-MIME) content-*: fields        unless ($ismime) {
601          $self->{header}->add ('mime-version' => '1.0',          $ismime = 1 if $option{force_mime_entity}
602            -parse => 0, -ns => $option{fill_mimever_ns});                      || $option{fill_md5}
603                        || $option{body_default_media_type} ne 'text'
604                        || $option{body_default_media_subtype} ne 'plain';
605        }        }
606      }   # $ismime        if ($ismime) {
607      if ($option{format} =~ /uri-url-mailto/ && $exist{'type:$ns_content'}          ## Content-Type: (MIME, HTTP)
608            if ($option{fill_ct} && !$exist->{'type:'.$ns_content}) {
609                my $ct = $hdr->field ('type', -ns => $ns_content);
610                $ct->media_type ($option{body_default_media_type}.'/'
611                                .$option{body_default_media_subtype});
612                $ct->replace (Message::MIME::Charset::name_minimumize ($option{body_default_charset} => $body0));
613            }
614            ## MIME-Version: (MIME)
615            if ($option{fill_mimever}
616                && !$exist->{'mime-version:'.$option{fill_mimever_ns}}) {
617              ## BUG: doesn't support rfc1049, HTTP (ie. non-MIME) content-*: fields
618              $hdr->add ('mime-version' => '1.0',
619                -parse => 0, -ns => $option{fill_mimever_ns});
620            }
621          } # $ismime
622          ## User-Agent: (USEFOR, HTTP)
623          if ($option{add_ua}) {
624            $hdr->field ($option{fill_ua_name})->add_our_name (
625              -use_Config   => $option{ua_use_Config},
626              -use_Win32    => $option{ua_use_Win32},
627              -date => q$Date$,
628            );
629          }
630        } if $option{fill_missing_fields};
631        
632        if ($option{format} =~ /uri-url-mailto/
633         && $self->{header}->field_exist ('type', -ns => $ns_content)
634       && $option{uri_mailto_safe_level} > 1) {       && $option{uri_mailto_safe_level} > 1) {
635        $self->{header}->field ('content-type')->media_type ('text/plain');        $self->{header}->field ('type', -ns => $ns_content)->media_type ('text/plain');
636      }      }
637      if ($option{add_ua}) {      $header = $self->{header}->stringify (
638        $self->{header}->field ($option{fill_ua_name})->add_our_name (          -format => $option{format},
639          -use_Config     => $option{ua_use_Config},          -linebreak_strict => $option{linebreak_strict},
640          -use_Win32      => $option{ua_use_Win32},          -uri_mailto_safe_level => $option{uri_mailto_safe_level},
641        );          ($filler? (-hook_stringify_fill_fields  => $filler) :()),
642      }      );
     $header = $self->{header}->stringify (-format => $option{format},  
       -linebreak_strict => $option{linebreak_strict},  
       -uri_mailto_safe_level => $option{uri_mailto_safe_level});  
643    } else {    } else {
644      $header = $self->{header};      $header = $self->{header};
645      unless ($option{linebreak_strict}) {      unless ($option{linebreak_strict}) {
# Line 583  sub stringify ($;%) { Line 666  sub stringify ($;%) {
666        $to||$header? 'mailto:'.$to.$header: '';        $to||$header? 'mailto:'.$to.$header: '';
667      }      }
668    } else {    } else {
669        ## Magic line (<- named by the author of this module:-)
670        my $mline;
671        if ($option{use_magic_line} && $option{output_magic_line}) {
672          if ($option{format} =~ /mail|news/ && ref $self->{header}) {
673            my $mfrom = $self->{header}->field ('mail-from', -new_item_unless_exist=>0);
674            $mline = sprintf 'From %s', $mfrom->value if ref $mfrom;
675          } elsif ($option{format} =~ /http.+?request/) {
676            $mline = sprintf '%s %s %s/%vd', $self->{http_method} || 'GET',
677              $self->{http_request_uri} || '/', $self->{http_protocol_name} || 'HTTP',
678              $self->{http_protocol_version} || v1.0;
679          } elsif ($option{format} =~ /http.+?response/ && ref $self->{header}
680                && $option{format} !~ /cgi/) {
681            my $s = $self->{header}->field ('x-http-status');
682            $mline = sprintf '%s/%vd %s', $self->{http_protocol_name} || 'HTTP',
683              $self->{http_protocol_version} || v1.0, $s->value || '200 OK';
684          }
685        }
686        $mline .= "\x0D\x0A" if $mline;
687        $mline = '' unless $mline;
688        
689      $header .= "\x0D\x0A" if $header && $header !~ /\x0D\x0A$/;      $header .= "\x0D\x0A" if $header && $header !~ /\x0D\x0A$/;
690      $header."\x0D\x0A".$body;      $mline.$header."\x0D\x0A".$body;
691    }    }
692  }  }
693  *as_string = \&stringify;  *as_string = \&stringify;
# Line 614  Example: Line 717  Example:
717  sub content_type ($;%) {  sub content_type ($;%) {
718    my $self = shift;    my $self = shift;
719    my $ct = $self->{header}->field ('content-type', -new_item_unless_exist => 0);    my $ct = $self->{header}->field ('content-type', -new_item_unless_exist => 0);
720      my ($mt, $mst);
721    unless (ref $ct) {    unless (ref $ct) {
722      if ($self->{option}->{body_default_media_type} ne 'text'      $mt = $self->{option}->{body_default_media_type};
723       || $self->{option}->{body_default_media_subtype} ne 'plain') {      $mst = $self->{option}->{body_default_media_subtype};
724        if ($mt ne 'text' || $mst ne 'plain') {
725        $ct = $self->{header}->field ('content-type');        $ct = $self->{header}->field ('content-type');
726        $ct->media_type_major ($self->{option}->{body_default_media_type});        $ct->media_type_major ($mt);
727        $ct->media_type_minor ($self->{option}->{body_default_media_subtype});        $ct->media_type_minor ($mst);
728        }
729        if ($self->{option}->{guess_media_type} && $self->{body} && !ref $self->{body}
730         && $self->{option}->{format} =~ /mail|news/) {
731          if ($self->{body} =~ /^-----BEGIN PGP SIGNED MESSAGE-----\x0D?$/m
732            && $self->{body} =~ /^-----BEGIN PGP SIGNATURE-----\x0D?$/m
733            && $self->{body} =~ /^-----END PGP SIGNATURE-----\x0D?$/m) {
734            $ct = $self->{header}->field ('content-type') unless ref $ct;
735            $mt = $ct->media_type_major ('text');
736            $mst = $ct->media_type_minor ('x-pgp-cleartext-signed');
737          } elsif ($self->{body} =~ /^-----BEGIN PGP [A-Z\x20]+-----\x0D?$/m
738            && $self->{body} =~ /^-----END PGP [A-Z\x20]+-----\x0D?$/m) {
739            $ct = $self->{header}->field ('content-type') unless ref $ct;
740            $mt = $ct->media_type_major ('application');
741            $mst = $ct->media_type_minor ('pgp');
742            $ct->parameter (format => 'text');
743          } elsif ($self->{body} =~ /^-+ start of forwarded message \(RFC 934 encapsulation\) -+\x0D?$/m) {
744            $ct = $self->{header}->field ('content-type') unless ref $ct;
745            $mt = $ct->media_type_major ('text');
746            $mst = $ct->media_type_minor ('x-message-rfc934');
747          } elsif ($self->{body} =~ /^-{70,70}\x0D?$/m
748            && $self->{body} =~ /^-{30,30}\x0D?$/m
749            && $self->{body} =~ /\x0D?\x0A-{30,30}\x0D?\x0A\x0D?\x0AEnd of.+?Digest.*?\x0D?\x0A\*+(?:\x0D?\x0A)*$/s) {
750            $ct = $self->{header}->field ('content-type') unless ref $ct;
751            $mt = $ct->media_type_major ('text');
752            $mst = $ct->media_type_minor ('x-message-rfc1153');
753          } elsif ($self->{body} =~ /^-----PRIVACY-ENHANCED MESSAGE BOUNDARY-----\x0D?$/m) {
754            $ct = $self->{header}->field ('content-type') unless ref $ct;
755            $mt = $ct->media_type_major ('text');
756            $mst = $ct->media_type_minor ('x-message-pem');
757          } elsif ($self->{body} =~ /^#(?:HELO|EHLO)/mi
758                && $self->{body} =~ /^#MAIL FROM:/mi
759                && $self->{body} !~ /^[^#]/m) {
760            ## RFC 976 Batch SMTP (BSMTP) message
761            $ct = $self->{header}->field ('content-type') unless ref $ct;
762            $mt = $ct->media_type_major ('application');
763            $mst = $ct->media_type_minor ('x-batch-smtp');
764          }
765        }
766      } else {
767        ($mt, $mst) = ($ct->media_type_major, $ct->media_type_minor);
768      }
769      if ($self->{option}->{guess_media_type}) {
770        if ($mt eq 'text' && $mst eq 'plain') {
771          my $mls = $self->{header}->field ('x-mlserver', -new_item_unless_exist => 0);
772          if (ref $mls && $mls =~ /fml/) {
773            my $s = $self->{header}->field ('subject', -new_item_unless_exist => 0);
774            if (index ($s, 'RFC934(mh-burst)') >= 0) {
775              $ct = $self->{header}->field ('content-type') unless ref $ct;
776              $mt = $ct->media_type_major ('text');
777              $mst = $ct->media_type_minor ('x-message-rfc934');
778              $ct->delete ('charset');
779            } elsif (index ($s, 'Digest (RFC1153)') >= 0) {
780              $ct = $self->{header}->field ('content-type') unless ref $ct;
781              $mt = $ct->media_type_major ('text');
782              $mst = $ct->media_type_minor ('x-message-rfc1153');
783              $ct->delete ('charset');
784            }
785          }
786      }      }
     return wantarray? ($self->{option}->{body_default_media_type},  
                        $self->{option}->{body_default_media_subtype}):  
                       $self->{option}->{body_default_media_type}.'/'  
                       .$self->{option}->{body_default_media_subtype};  
787    }    }
788    if (wantarray) {    if (wantarray) {
789      ($ct->media_type_major, $ct->media_type_minor);      ($mt, $mst);
790    } else {    } else {
791      $ct->media_type;      ref $ct ? $ct->media_type : sprintf '%s/%s', $mt, $mst;
792    }    }
793  }  }
794  *media_type = \&content_type;  *media_type = \&content_type;
# Line 652  sub id ($) { Line 811  sub id ($) {
811    '';    '';
812  }  }
813    
814    sub sender ($;%) {
815      my $self = shift;
816      my %params = @_;
817      my %option = %{$self->{option}};
818      $option{use_x_envelope_from} = 1;     ## X-Envelope-From:
819      $option{use_normal} = 1;      ## From:, Sender:
820      $option{use_resent} = 1;      ## Resent-From:, Resent-Sender:
821      my $hdr = $self->{header};
822      if ($option{use_x_envelope_from} && $hdr->field_exist ('x-envelope-from')) {
823        return $hdr->field ('x-envelope-from')->addr_spec;
824      } elsif ($option{use_resent} && $hdr->field_exist ('resent-sender')) {
825        ## TODO: Resent block support
826        return $hdr->field ('resent-sender')->addr_spec;
827      } elsif ($option{use_resent} && $hdr->field_exist ('resent-from')) {
828        ## TODO: Resent block support
829        return $hdr->field ('resent-from')->addr_spec;
830      } elsif ($option{use_normal} && $hdr->field_exist ('sender')) {
831        return $hdr->field ('sender')->addr_spec;
832      } elsif ($option{use_normal} && $hdr->field_exist ('from')) {
833        return $hdr->field ('from')->addr_spec;
834      }
835      undef;
836    }
837    
838    sub destination ($;%) {
839      my $self = shift;
840      my %params = @_;
841      my %option = %{$self->{option}};
842      $option{use_x_envelope_to} = 1;       ## X-Envelope-To:
843      $option{use_normal} = 1;      ## To:, Cc:, Bcc:
844      $option{use_resent} = 1;      ## Resent-To:, Resent-Cc:, Resent-Bcc:
845      for (grep {/^-/} keys %params) {$option{substr ($_, 1)} = $params{$_}}
846      my $hdr = $self->{header};
847      my @to;
848      if ($option{use_x_envelope_to} && $hdr->field_exist ('x-rfc822-x-envelope-to')) {
849        @to = $hdr->field ('x-rfc822-x-envelope-to')->addr_spec;
850      } elsif ($option{use_resent} && $hdr->field_exist ('x-rfc822-resent-from')) {
851        ## TODO: Resent block support
852        @to = ($hdr->field ('x-rfc822-resent-to')->addr_spec,
853               $hdr->field ('x-rfc822-resent-cc')->addr_spec,
854               $hdr->field ('x-rfc822-resent-bcc')->addr_spec);
855      } elsif ($option{use_normal}) {
856        @to = ($hdr->field ('x-rfc822-to')->addr_spec,
857               $hdr->field ('x-rfc822-cc')->addr_spec,
858               $hdr->field ('x-rfc822-bcc')->addr_spec);
859      }
860      @to;
861    }
862    
863    sub list_name ($) {
864      my $self = shift;
865      my $hdr = $self->{header};
866      if ($hdr->field_exist ('list-id')) {
867        my $lname = $hdr->field ('list-id')->display_name;
868        return $lname if length $lname;
869      }
870      my $v = sub {
871        my $name = shift;
872        my $f = $hdr->field ($name, -new_item_unless_exist => 0);
873        return $f->value if ref $f;
874        undef;
875      };
876      ## BUG: list-name "0" is not supported.
877      my $lname = &$v ('x-ml-name') || &$v ('x-mailing-list-name')
878               || &$v ('x-mailinglist-name') || &$v ('ml-name');
879      return $lname if length $lname;
880      if ($hdr->field_exist ('x-sequence')) {
881        if ($hdr->field ('x-sequence')->value =~ /^(\S+)\s+\d+$/) {
882          return $1;
883        }
884      }
885      if ($hdr->field_exist ('subject')) {
886        my $s = $hdr->field ('subject');
887        return $s->list_name if $s->method_available ('list_name');
888      }
889      undef;
890    }
891    
892    sub list_count ($) {
893      my $self = shift;
894      my $hdr = $self->{header};
895      my $v = sub {
896        my $name = shift;
897        my $f = $hdr->field ($name, -new_item_unless_exist => 0);
898        return $f->value if ref $f;
899        undef;
900      };
901      ## BUG: list-count 0 is not supported.
902      my $lc = &$v ('x-mail-count') || &$v ('x-ml-count') || &$v ('x-mailinglist-id')
903               || &$v ('mail-count') || &$v ('x-article-no') || &$v ('x-ml-counter')
904               || &$v ('x-ml-id') || &$v ('x-ml-sequence') || &$v ('x-serial-no')
905               || &$v ('x-seqno');
906      return $lc if $lc;
907      if ($hdr->field_exist ('x-sequence')) {
908        my $s = $hdr->field ('x-sequence')->value;
909        if ($s =~ /^\S+\s+(\d+)$/) {
910          return $1;
911        } elsif ($s =~ /(\d+)/) {
912          return $1;
913        }
914      }
915      if ($hdr->field_exist ('subject')) {
916        my $s = $hdr->field ('subject');
917        return $s->list_count if $s->method_available ('list_count');
918      }
919      undef;
920    }
921    
922  =back  =back
923    
924  =head1 MISC. METHODS  =head1 MISC. METHODS
# Line 679  sub option ($@) { Line 946  sub option ($@) {
946    my %option = @_;    my %option = @_;
947    while (my ($name, $value) = splice (@_, 0, 2)) {    while (my ($name, $value) = splice (@_, 0, 2)) {
948      $self->{option}->{$name} = $value;      $self->{option}->{$name} = $value;
     if ($name eq 'format') {  
       $self->header->option (-format => $value);  
     }  
949    }    }
950    if ($option{-recursive}) {    if ($option{-recursive} && ($self->content_type)[0] ne 'message') {
951      $self->{header}->option (%option);      $self->{header}->option (%option);
952      $self->{body}->option (%option) if ref $self->{body};      $self->{body}->option (%option) if ref $self->{body};
953    }    }
# Line 716  sub method_available ($$) { Line 980  sub method_available ($$) {
980    0;    0;
981  }  }
982    
983    sub import ($;%) {
984      my $self = shift;
985      my %option = @_;
986      for (keys %option) {
987        $DEFAULT{$_} = $option{$_};
988      }
989      if ($option{-body_default_charset} && !$option{-body_default_charset_input}) {
990        $DEFAULT{-body_default_charset_input} = $option{-body_default_charset};
991      }
992      if ($option{-header_default_charset} && !$option{-header_default_charset_input}) {
993        $DEFAULT{-header_default_charset_input} = $option{-header_default_charset};
994      }
995    }
996    
997  =back  =back
998    
999  =head1 C<format>  =head1 C<format>
# Line 738  Internet mail message, defined by IETF R Line 1016  Internet mail message, defined by IETF R
1016    
1017  Internet mail message, defined by IETF RFC 822  Internet mail message, defined by IETF RFC 822
1018    
1019    =item mail-rfc822+rfc1123
1020    
1021    Internet mail message, defined by IETF RFC 822, ammended by RFC 1123
1022    
1023  =item mail-rfc2822  =item mail-rfc2822
1024    
1025  Internet mail message, defined by IETF RFC 2822  Internet mail message, defined by IETF RFC 2822
# Line 818  HTTP/1.1 response message, defined by IE Line 1100  HTTP/1.1 response message, defined by IE
1100    
1101  CGI/1.1 output (for HTTP), defined by coar-cgi-v11 (IETF Internet Draft)  CGI/1.1 output (for HTTP), defined by coar-cgi-v11 (IETF Internet Draft)
1102    
 =item http-1.0-cgi-1.1  
   
 CGI/1.1 output (for HTTP/1.0), defined by coar-cgi-v11 (IETF Internet Draft)  
   
 =item http-1.1-cgi-1.1  
   
 CGI/1.1 output (for HTTP/1.1), defined by coar-cgi-v11 (IETF Internet Draft)  
   
1103  =item http-cgi-1.2  =item http-cgi-1.2
1104    
1105  CGI/1.2 output, defined by coar-cgi-v12 (to be IETF Internet Draft)  CGI/1.2 output, defined by coar-cgi-v12 (to be IETF Internet Draft)
1106    
 =item http-1.0-cgi-1.2  
   
 CGI/1.2 output (for HTTP/1.0), defined by coar-cgi-v11 (IETF Internet Draft)  
   
 =item http-1.1-cgi-1.2  
   
 CGI/1.2 output (for HTTP/1.1), defined by coar-cgi-v11 (IETF Internet Draft)  
   
1107  =item http-sip-2.0  =item http-sip-2.0
1108    
1109  SIP/2.0 message, defined by IETF RFC 2543  SIP/2.0 message, defined by IETF RFC 2543
# Line 858  SIP/2.0 CGI (IETF Internet Draft) Line 1124  SIP/2.0 CGI (IETF Internet Draft)
1124    
1125  CPIM/1.0 (IETF Internet Draft)  CPIM/1.0 (IETF Internet Draft)
1126    
1127  =item uri-url-mailto-mail-rfc822, uri-url-mailto-mail-rfc2822  =item uri-url-mailto
1128    
1129  mailto: URL scheme  mailto: URL scheme
1130    
# Line 866  mailto: URL scheme Line 1132  mailto: URL scheme
1132    
1133  mailto: URL scheme (defined by RFC 1738)  mailto: URL scheme (defined by RFC 1738)
1134    
1135  =item uri-url-mailto-rfc2368, uri-url-mailto-rfc2822  =item uri-url-mailto-rfc2368
1136    
1137  mailto: URL scheme (defined by RFC 2368)  mailto: URL scheme (defined by RFC 2368)
1138    
1139  =item uri-url-mailto-to-mail-rfc822, uri-url-mailto-to-mail-rfc2822  =item uri-url-mailto-to
1140    
1141  C<to> part of mailto: URL scheme (for internal use only)  C<to> part of mailto: URL scheme (for internal use only)
1142    
# Line 895  Message::* Perl modules Line 1161  Message::* Perl modules
1161    
1162  =head1 LICENSE  =head1 LICENSE
1163    
1164  Copyright 2002 wakaba E<lt>[email protected]<gt>.  Copyright 2002 Wakaba <[email protected]>.
1165    
1166  This program is free software; you can redistribute it and/or modify  This program is free software; you can redistribute it and/or modify
1167  it under the terms of the GNU General Public License as published by  it under the terms of the GNU General Public License as published by
Legend:
Removed from v.1.26  
changed lines
  Added in v.1.39
[email protected]
 ViewVC Help
Powered by ViewVC 1.1.24