/[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.9 by wakaba, Fri Apr 5 14:56:26 2002 UTC revision 1.13 by wakaba, Wed May 15 07:31:28 2002 UTC
# Line 29  sub _init ($;%) { Line 29  sub _init ($;%) {
29      #fill_date  => 1,      #fill_date  => 1,
30      #fill_msgid => 1,      #fill_msgid => 1,
31      format      => 'mail-rfc2822',      format      => 'mail-rfc2822',
32        linebreak_strict    => 0,   ## BUG: not work perfectly
33      parse_all   => 0,      parse_all   => 0,
34      #ua_field_name      => 'user-agent',      #ua_field_name      => 'user-agent',
35      ua_use_config       => 1,      ua_use_config       => 1,
36        uri_mailto_safe_level       => 4,
37    };    };
38    my @new_fields = ();    my @new_fields = ();
39    for my $name (keys %options) {    for my $name (keys %options) {
# Line 43  sub _init ($;%) { Line 45  sub _init ($;%) {
45    }    }
46    my $format = $self->{option}->{format};    my $format = $self->{option}->{format};
47    unless (defined $self->{option}->{fill_date}) {    unless (defined $self->{option}->{fill_date}) {
48      $self->{option}->{fill_date} = $format !~ /^cgi/;      $self->{option}->{fill_date} = $format !~ /cgi|uri-url-mailto/;
49    }    }
50    unless (defined $self->{option}->{fill_msgid}) {    unless (defined $self->{option}->{fill_msgid}) {
51      $self->{option}->{fill_msgid} = $format !~ /^(?:cgi|http)/;      $self->{option}->{fill_msgid} = $format !~ /http|uri-url-mailto/;
52    }    }
53    unless (defined $self->{option}->{fill_mimever}) {    unless (defined $self->{option}->{fill_mimever}) {
54      $self->{option}->{fill_mimever} = $format !~ /^(?:cgi|http)/;      $self->{option}->{fill_mimever} = $format !~ /http/;
55    }    }
56    unless (length $self->{option}->{ua_field_name}) {    unless (length $self->{option}->{ua_field_name}) {
57      $self->{option}->{ua_field_name} = $format =~ /^(?:http-response|cgi)/?      $self->{option}->{ua_field_name} = $format =~ /response|cgi|uri-url-mailto/?
58        'server': 'user-agent';        'server': 'user-agent';
59    }    }
60    @new_fields;    @new_fields;
# Line 107  sub parse ($$;%) { Line 109  sub parse ($$;%) {
109    my $message = shift;    my $message = shift;
110    my $self = bless {}, $class;    my $self = bless {}, $class;
111    my %new_field = $self->_init (@_);    my %new_field = $self->_init (@_);
112    my @header = ();    my @header = ();      ## BUG: don't check linebreak_strict
113    my @body = split /\x0D?\x0A/, $message;       ## BUG: not binary-clean...    my @body = split /\x0D?\x0A/, $message;       ## BUG: not binary-clean...
114    while (1) {    while (1) {
115      my $line = shift @body;      my $line = shift @body;
# Line 121  sub parse ($$;%) { Line 123  sub parse ($$;%) {
123    $self->{header} = parse_array Message::Header \@header,    $self->{header} = parse_array Message::Header \@header,
124      -parse_all => $self->{option}->{parse_all},      -parse_all => $self->{option}->{parse_all},
125      -format => $self->{option}->{format}, %new_field;      -format => $self->{option}->{format}, %new_field;
126    $self->{body} = join "\n", @body;    $self->{body} = join "\n", @body;     ## BUG: binary-unsafe
127    $self->{body} = $self->_body ($self->{body}, $self->content_type)    $self->{body} = $self->_body ($self->{body}, $self->content_type)
128      if $self->{option}->{parse_all};      if $self->{option}->{parse_all};
129    $self;    $self;
# Line 203  sub stringify ($;%) { Line 205  sub stringify ($;%) {
205    my %params = @_;    my %params = @_;
206    my %option = %{$self->{option}};    my %option = %{$self->{option}};
207    for (grep {/^-/} keys %params) {$option{substr ($_, 1)} = $params{$_}}    for (grep {/^-/} keys %params) {$option{substr ($_, 1)} = $params{$_}}
208      my ($header, $body);    my ($header, $body);
209      if (ref $self->{header}) {    if (ref $self->{header}) {
210        my %exist;      my %exist;
211        for ($self->{header}->field_name_list) {$exist{$_} = 1}      for ($self->{header}->field_name_list) {$exist{$_} = 1}
212        if ($option{fill_date} && !$exist{'date'}) {      if ($option{fill_date} && !$exist{'date'}) {
213          $self->{header}->field ('date')->unix_time (time);        $self->{header}->field ('date')->unix_time (time);
214        }      }
215      if ($option{fill_msgid} && !$exist{'message-id'}) {      if ($option{fill_msgid} && !$exist{'message-id'}) {
216        my $from = $self->{header}->field ('from')->addr_spec (1);        my $from = $self->{header}->field ('from')->addr_spec;
217        $self->{header}->field ('message-id')->add_new (addr_spec => $from)        $self->{header}->field ('message-id')->generate (addr_spec => $from)
218          if $from;          if $from;
219      }      }
220      if ($option{fill_mimever} && !$exist{'mime-version'}) {      if ($option{fill_mimever} && !$exist{'mime-version'}) {
# Line 223  sub stringify ($;%) { Line 225  sub stringify ($;%) {
225          $self->{header}->add ('mime-version' => '1.0', -parse => 0);          $self->{header}->add ('mime-version' => '1.0', -parse => 0);
226        }        }
227      }      }
228        if ($option{format} =~ /uri-url-mailto/ && $exist{'content-type'}
229         && $option{uri_mailto_safe_level} > 1) {
230          $self->{header}->field ('content-type')->media_type ('text/plain');
231        }
232      $self->_add_ua_field;      $self->_add_ua_field;
233      $header = $self->{header}->stringify (-format => $option{format});      $header = $self->{header}->stringify (-format => $option{format},
234          -linebreak_strict => $option{linebreak_strict},
235          -uri_mailto_safe_level => $option{uri_mailto_safe_level});
236    } else {    } else {
237      $header = $self->{header};      $header = $self->{header};
238      $header =~ s/\x0D(?=[^\x09\x0A\x20])/\x0D\x20-/g;      unless ($option{linebreak_strict}) {
239      $header =~ s/\x0A(?=[^\x09\x20])/\x0A\x20-/g;        ## bare \x0D and bare \x0A are unsafe
240          $header =~ s/\x0D(?=[^\x09\x0A\x20])/\x0D\x20/g;
241          $header =~ s/\x0A(?=[^\x09\x20])/\x0A\x20/g;
242        }
243    }    }
244    if (ref $self->{body}) {    if (ref $self->{body}) {
245      $body = $self->{body}->stringify (-format => $option{format});      $body = $self->{body}->stringify (-format => $option{format},
246          -linebreak_strict => $option{linebreak_strict});
247    } else {    } else {
248      $body = $self->{body};      $body = $self->{body};
249    }    }
250    $header .= "\n" if $header && $header !~ /\n$/;    if ($option{format} =~ /uri-url-mailto/) {
251    $header."\n".$body;      my $f = $option{format};  $f =~ s/-mailto/-mailto-to/;
252        my $to = $self->{header}->stringify (-format => $f,
253          -uri_mailto_safe_level => $option{uri_mailto_safe_level});
254        $body =~ s/([^:@+\$A-Za-z0-9\-_.!~*])/sprintf('%%%02X', ord $1)/ge;
255        if (length $body) {
256          $header .= '&' if $header;
257          $header .= 'body='.$body;
258        }
259        $header = '?'.$header if $header;
260        'mailto:'.$to.$header;
261      } else {
262        $header .= "\n" if $header && $header !~ /\n$/;
263        $header."\n".$body;
264      }
265  }  }
266  *as_string = \&stringify;  *as_string = \&stringify;
267    
# Line 292  sub _add_ua_field ($) { Line 317  sub _add_ua_field ($) {
317    my $self = shift;    my $self = shift;
318    if ($self->{option}->{add_ua}) {    if ($self->{option}->{add_ua}) {
319      my $ua = $self->{header}->field ($self->{option}->{ua_field_name});      my $ua = $self->{header}->field ($self->{option}->{ua_field_name});
320      $ua->replace (name => 'Message-pm', version => $VERSION, add_prepend => -1);      $ua->replace ('Message-pm' => $VERSION, -prepend => 0);
321      my @os;      my @os;
322      my @perl_comment;      my @perl_comment;
323      if ($self->{option}->{ua_use_config}) {      if ($self->{option}->{ua_use_config}) {
324        eval q{use Config;        eval q{use Config;
325          @os = (name => $^O, version => $Config{osvers}, add_prepend => -1);          @os = ($^O => $Config{osvers}, -prepend => 0);
326          push @perl_comment, $Config{archname};          push @perl_comment, $Config{archname};
327        };        };
328      } else {      } else {
329        push @perl_comment, $^O;        push @perl_comment, $^O;
330      }      }
331      if ($^V) {  ## 5.6 or later      if ($^V) {  ## 5.6 or later
332        $ua->replace (name => 'Perl', version => sprintf ('%vd', $^V),        $ua->replace (Perl => [sprintf ('%vd', $^V), @perl_comment], -prepend => 0);
                     comment => [@perl_comment], add_prepend => -1);  
333      } elsif ($]) {      ## Before 5.005      } elsif ($]) {      ## Before 5.005
334        $ua->replace (name => 'Perl', version => $],        $ua->replace (Perl => [ $], @perl_comment], -prepend => 0);
                     comment => [@perl_comment], add_prepend => -1);  
335      }      }
336      $ua->replace (@os) if $self->{option}->{ua_use_config};      $ua->replace (@os) if $self->{option}->{ua_use_config};
337    }    }
# Line 380  sub clone ($) { Line 403  sub clone ($) {
403    
404  =back  =back
405    
406    =head1 C<format>
407    
408    =over 2
409    
410    =item mail-rfc650
411    
412    Internet mail message, defined by IETF RFC 650
413    
414    =item mail-rfc724
415    
416    Internet mail message, defined by IETF RFC 724
417    
418    =item mail-rfc733
419    
420    Internet mail message, defined by IETF RFC 733
421    
422    =item mail-rfc822
423    
424    Internet mail message, defined by IETF RFC 822
425    
426    =item mail-rfc2822
427    
428    Internet mail message, defined by IETF RFC 2822
429    
430    =item mime-1.0
431    
432    MIME entity
433    
434    =item mime-1.0-rfc1341
435    
436    MIME entity, defined by RFC 1341 (and RFC 1342)
437    
438    =item mime-1.0-rfc1521
439    
440    MIME entity, defined by RFC 1521 and 1522
441    
442    =item mime-1.0-rfc2045
443    
444    MIME entity, defined by RFC 2045,..., 2049
445    
446    =item news-bnews
447    
448    Usenet Bnews format
449    
450    =item news-rfc850
451    
452    Usenet news format, defined by IETF RFC 850
453    
454    =item news-rfc1036
455    
456    Usenet news format, defined by IETF RFC 1036
457    
458    =item news-son-of-rfc1036
459    
460    Usenet news format, defined by son-of-RFC1036
461    
462    =item news-usefor
463    
464    Usenet news format, defined by usefor-article (IETF Internet Draft)
465    
466    =item http-1.0-rfc1945
467    
468    HTTP/1.0 message, defined by IETF RFC 1945
469    
470    =item http-1.0-rfc1945-request
471    
472    HTTP/1.0 request message, defined by IETF RFC 1945
473    
474    =item http-1.0-rfc1945-response
475    
476    HTTP/1.0 response message, defined by IETF RFC 1945
477    
478    =item http-1.1-rfc2068
479    
480    HTTP/1.1 message, defined by IETF RFC 2068
481    
482    =item http-1.1-rfc2068-request
483    
484    HTTP/1.1 request message, defined by IETF RFC 2068
485    
486    =item http-1.1-rfc2068-response
487    
488    HTTP/1.1 response message, defined by IETF RFC 2068
489    
490    =item http-1.1-rfc2616
491    
492    HTTP/1.1 message, defined by IETF RFC 2616
493    
494    =item http-1.1-rfc2616-request
495    
496    HTTP/1.1 request message, defined by IETF RFC 2616
497    
498    =item http-1.1-rfc2616-response
499    
500    HTTP/1.1 response message, defined by IETF RFC 2616
501    
502    =item http-cgi-1.1
503    
504    CGI/1.1 output (for HTTP), defined by coar-cgi-v11 (IETF Internet Draft)
505    
506    =item http-1.0-cgi-1.1
507    
508    CGI/1.1 output (for HTTP/1.0), defined by coar-cgi-v11 (IETF Internet Draft)
509    
510    =item http-1.1-cgi-1.1
511    
512    CGI/1.1 output (for HTTP/1.1), defined by coar-cgi-v11 (IETF Internet Draft)
513    
514    =item http-cgi-1.2
515    
516    CGI/1.2 output, defined by coar-cgi-v12 (to be IETF Internet Draft)
517    
518    =item http-1.0-cgi-1.2
519    
520    CGI/1.2 output (for HTTP/1.0), defined by coar-cgi-v11 (IETF Internet Draft)
521    
522    =item http-1.1-cgi-1.2
523    
524    CGI/1.2 output (for HTTP/1.1), defined by coar-cgi-v11 (IETF Internet Draft)
525    
526    =item http-sip-2.0
527    
528    SIP/2.0 message, defined by IETF RFC 2543
529    
530    =item http-sip-2.0-request
531    
532    SIP/2.0 request message, defined by IETF RFC 2543
533    
534    =item http-sip-2.0-response
535    
536    SIP/2.0 response message, defined by IETF RFC 2543
537    
538    =item http-sip-cgi
539    
540    SIP/2.0 CGI (IETF Internet Draft)
541    
542    =item cpim-1.0
543    
544    CPIM/1.0 (IETF Internet Draft)
545    
546    =item uri-url-mailto-mail-rfc822, uri-url-mailto-mail-rfc2822
547    
548    mailto: URL scheme
549    
550    =item uri-url-mailto-rfc1738
551    
552    mailto: URL scheme (defined by RFC 1738)
553    
554    =item uri-url-mailto-rfc2368, uri-url-mailto-rfc2822
555    
556    mailto: URL scheme (defined by RFC 2368)
557    
558    =item uri-url-mailto-to-mail-rfc822, uri-url-mailto-to-mail-rfc2822
559    
560    C<to> part of mailto: URL scheme (for internal use only)
561    
562    =back
563    
564  =head1 EXAMPLE  =head1 EXAMPLE
565    
566    use Message::Entity;    use Message::Entity;
Legend:
Removed from v.1.9  
changed lines
  Added in v.1.13
[email protected]
 ViewVC Help
Powered by ViewVC 1.1.24