/[suikacvs]/test/cvs
Suika

Diff of /test/cvs

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

revision 1.4 by wakaba, Sat Mar 16 08:54:39 2002 UTC revision 1.13 by wakaba, Mon Apr 1 05:32:37 2002 UTC
# Line 13  package Message::Header; Line 13  package Message::Header;
13  use strict;  use strict;
14  use vars qw($VERSION %REG %DEFAULT);  use vars qw($VERSION %REG %DEFAULT);
15  $VERSION = '1.00';  $VERSION = '1.00';
16    use Carp;
17  use overload '@{}' => sub {shift->_delete_empty_field()->{field}},  use overload '@{}' => sub {shift->_delete_empty_field()->{field}},
18               '""' => sub {shift->stringify};               '""' => sub {shift->stringify};
19    
# Line 47  when C<stringify>.  (Default = 0) Line 47  when C<stringify>.  (Default = 0)
47  %DEFAULT = (  %DEFAULT = (
48    capitalize    => 1,    capitalize    => 1,
49    fold_length   => 70,    fold_length   => 70,
50    mail_from     => 0,    field_type    => {':DEFAULT' => 'Message::Field::Unstructured'},
51    field_type    => {_DEFAULT => 'Message::Field::Unstructured'},    format        => 'rfc2822',   ## rfc2822, usefor, http
52      mail_from     => -1,
53      output_bcc    => -1,
54      parse_all     => -1,
55  );  );
56  my @field_type_Structured = qw(cancel-lock content-language  my @field_type_Structured = qw(cancel-lock
57    content-transfer-encoding    importance path precedence
58    encrypted importance mime-version precedence user-agent x-cite    x-face x-mail-count x-msmail-priority x-priority xref);
   x-face x-mail-count  
   x-msmail-priority x-priority x-uidl xref);  
59  for (@field_type_Structured)  for (@field_type_Structured)
60    {$DEFAULT{field_type}->{$_} = 'Message::Field::Structured'}    {$DEFAULT{field_type}->{$_} = 'Message::Field::Structured'}
61  my @field_type_Address = qw(approved bcc cc delivered-to envelope-to  my @field_type_Address = qw(approved bcc cc delivered-to disposition-notification-to
62    errors-to from mail-followup-to reply-to resent-bcc    envelope-to
63      errors-to fcc from mail-followup-to mail-followup-cc mail-from reply-to resent-bcc
64    resent-cc resent-to resent-from resent-sender return-path    resent-cc resent-to resent-from resent-sender return-path
65    return-receipt-to sender to x-approved x-beenthere    return-receipt-to sender to x-approved x-beenthere
66    x-complaints-to x-envelope-from x-envelope-sender    x-complaints-to x-envelope-from x-envelope-sender
67    x-envelope-to x-ml-address x-ml-command x-ml-to);    x-envelope-to x-ml-address x-ml-command x-ml-to x-nfrom x-nto);
68  for (@field_type_Address)  for (@field_type_Address)
69    {$DEFAULT{field_type}->{$_} = 'Message::Field::Address'}    {$DEFAULT{field_type}->{$_} = 'Message::Field::Address'}
70  my @field_type_Date = qw(date date-received delivery-date expires  my @field_type_Date = qw(date date-received delivery-date expires
71    expire-date nntp-posting-date posted reply-by resent-date x-tcup-date);    expire-date nntp-posting-date posted reply-by resent-date x-tcup-date);
72  for (@field_type_Date)  for (@field_type_Date)
73    {$DEFAULT{field_type}->{$_} = 'Message::Field::Date'}    {$DEFAULT{field_type}->{$_} = 'Message::Field::Date'}
74  my @field_type_MsgID = qw(content-id in-reply-to message-id  my @field_type_MsgID = qw(article-updates content-id in-reply-to message-id
75    references resent-message-id supersedes);    references resent-message-id see-also supersedes);
76  for (@field_type_MsgID)  for (@field_type_MsgID)
77      {$DEFAULT{field_type}->{$_} = 'Message::Field::MsgID'}
78    for (qw(received x-received))
79      {$DEFAULT{field_type}->{$_} = 'Message::Field::Received'}
80    $DEFAULT{field_type}->{'content-type'} = 'Message::Field::ContentType';
81    $DEFAULT{field_type}->{'content-disposition'} = 'Message::Field::ContentDisposition';
82    for (qw(archive link x-face-type))
83      {$DEFAULT{field_type}->{$_} = 'Message::Field::ValueParams'}
84    for (qw(accept accept-charset accept-encoding accept-language
85      content-language
86      content-transfer-encoding encrypted followup-to keywords
87      list-archive list-digest list-help list-owner
88      list-post list-subscribe list-unsubscribe list-url uri newsgroups
89      x-brother x-daughter x-respect x-moe x-syster x-wife))
90      {$DEFAULT{field_type}->{$_} = 'Message::Field::CSV'}
91    for (qw(content-alias content-base content-location location referer
92      url x-home-page x-http_referer
93      x-info x-pgp-key x-ml-url x-uri x-url x-web))
94      {$DEFAULT{field_type}->{$_} = 'Message::Field::URI'}
95    for (qw(list-id))
96    {$DEFAULT{field_type}->{$_} = 'Message::Field::Structured'}    {$DEFAULT{field_type}->{$_} = 'Message::Field::Structured'}
97  my @field_type_Received = qw(received x-received);  for (qw(subject title x-nsubject))
98  for (@field_type_Received)    {$DEFAULT{field_type}->{$_} = 'Message::Field::Subject'}
99    {$DEFAULT{field_type}->{$_} = 'Message::Field::Structured'}  for (qw(list-software user-agent server))
100  my @field_type_Param = qw(content-disposition content-type    {$DEFAULT{field_type}->{$_} = 'Message::Field::UA'}
101    x-brother x-daughter x-face-type x-respect x-moe  for (qw(content-length lines max-forwards mime-version))
102    x-syster x-wife);    {$DEFAULT{field_type}->{$_} = 'Message::Field::Numval'}
 for (@field_type_Param)  
   {$DEFAULT{field_type}->{$_} = 'Message::Field::Structured'}  
 my @field_type_URI = qw(list-archive list-help list-owner  
   list-post list-subscribe list-unsubscribe uri url x-home-page x-http_referer  
   x-info x-pgp-key x-ml-url x-uri x-url x-web);  
 for (@field_type_URI)  
   {$DEFAULT{field_type}->{$_} = 'Message::Field::Structured'}  
 my @field_type_ListID = qw(list-id);  
 for (@field_type_ListID)  
   {$DEFAULT{field_type}->{$_} = 'Message::Field::Structured'}  
103    
104  =head2 Message::Header->new ([%option])  =head2 Message::Header->new ([%option])
105    
# Line 119  sub parse ($$;%) { Line 130  sub parse ($$;%) {
130    $header =~ s/\x0D?\x0A$REG{WSP}+/\x20/gos;    ## unfold    $header =~ s/\x0D?\x0A$REG{WSP}+/\x20/gos;    ## unfold
131    for my $field (split /\x0D?\x0A/, $header) {    for my $field (split /\x0D?\x0A/, $header) {
132      if ($field =~ /$REG{M_fromline}/) {      if ($field =~ /$REG{M_fromline}/) {
133        push @{$self->{field}}, {name => 'mail-from', body => $1};        my $body = $1;
134          $body = $self->_field_body ($body, 'mail-from')
135            if $self->{option}->{parse_all}>0;
136          push @{$self->{field}}, {name => 'mail-from', body => $body};
137      } elsif ($field =~ /$REG{M_field}/) {      } elsif ($field =~ /$REG{M_field}/) {
138        my ($name, $body) = ($1, $2);        my ($name, $body) = (lc $1, $2);
139        $name =~ s/$REG{WSP}+$//;        $name =~ s/$REG{WSP}+$//;
140        $body =~ s/$REG{WSP}+$//;        $body =~ s/$REG{WSP}+$//;
141        push @{$self->{field}}, {name => lc $name, body => $body};        $body = $self->_field_body ($body, $name) if $self->{option}->{parse_all}>0;
142          push @{$self->{field}}, {name => $name, body => $body};
143      }      }
144    }    }
145    $self;    $self;
# Line 146  sub field ($$) { Line 161  sub field ($$) {
161    for my $field (@{$self->{field}}) {    for my $field (@{$self->{field}}) {
162      if ($field->{name} eq $name) {      if ($field->{name} eq $name) {
163        unless (wantarray) {        unless (wantarray) {
164          return $self->_field_body ($field->{body}, $name);          $field->{body} = $self->_field_body ($field->{body}, $name);
165            return $field->{body};
166        } else {        } else {
167          push @ret, $self->_field_body ($field->{body}, $name);          $field->{body} = $self->_field_body ($field->{body}, $name);
168            push @ret, $field->{body};
169        }        }
170      }      }
171    }    }
172      if ($#ret < 0) {
173        return $self->add ($name);
174      }
175    @ret;    @ret;
176  }  }
177    
178    sub field_exist ($$) {
179      my $self = shift;
180      my $name = lc shift;
181      my @ret;
182      for my $field (@{$self->{field}}) {
183        return 1 if ($field->{name} eq $name);
184      }
185      0;
186    }
187    
188  =head2 $self->field_name ($index)  =head2 $self->field_name ($index)
189    
190  Returns C<field-name> of $index'th C<field>.  Returns C<field-name> of $index'th C<field>.
# Line 172  sub field_name ($$) { Line 202  sub field_name ($$) {
202  sub field_body ($$) {  sub field_body ($$) {
203    my $self = shift;    my $self = shift;
204    my $i = shift;    my $i = shift;
205    $self->_field_body ($self->{field}->[$i]->{body}, $self->{field}->[$i]->{name});    $self->{field}->[$i]->{body}
206       = $self->_field_body ($self->{field}->[$i]->{body}, $self->{field}->[$i]->{name});
207      $self->{field}->[$i]->{body};
208  }  }
209    
210  sub _field_body ($$$) {  sub _field_body ($$$) {
211    my $self = shift;    my $self = shift;
212    my ($body, $name) = @_;    my ($body, $name) = @_;
213    if (ref $body) {    unless (ref $body) {
     return $body;  
   } else {  
214      my $type = $self->{option}->{field_type}->{$name}      my $type = $self->{option}->{field_type}->{$name}
215              || $self->{option}->{field_type}->{_DEFAULT};              || $self->{option}->{field_type}->{':DEFAULT'};
216      eval "use $type";      eval "require $type";
217      return $type->parse ($body);      unless ($body) {
218          $body = $type->new (field_name => $name, format => $self->{option}->{format});
219        } else {
220          $body = $type->parse ($body, field_name => $name,
221            format => $self->{option}->{format});
222        }
223    }    }
224      $body;
225  }  }
226    
227  =head2 $self->field_name_list ()  =head2 $self->field_name_list ()
# Line 210  If you don't want duplicated C<field>s, Line 246  If you don't want duplicated C<field>s,
246    
247  =cut  =cut
248    
249  sub add ($$$) {  sub add ($$;$%) {
250    my $self = shift;    my $self = shift;
251    my ($name, $body) = (lc shift, shift);    my ($name, $body) = (lc shift, shift);
252      my %option = @_;
253    return 0 if $name =~ /$REG{UNSAFE_field_name}/;    return 0 if $name =~ /$REG{UNSAFE_field_name}/;
254    push @{$self->{field}}, {name => $name, body => $body};    $body = $self->_field_body ($body, $name);
255    $self;    if ($option{prepend}) {
256        unshift @{$self->{field}}, {name => $name, body => $body};
257      } else {
258        push @{$self->{field}}, {name => $name, body => $body};
259      }
260      $body;
261  }  }
262    
263  =head2 $self->relace ($field_name, $field_body)  =head2 $self->relace ($field_name, $field_body)
# Line 232  sub replace ($$$) { Line 274  sub replace ($$$) {
274    my $self = shift;    my $self = shift;
275    my ($name, $body) = (lc shift, shift);    my ($name, $body) = (lc shift, shift);
276    return 0 if $name =~ /$REG{UNSAFE_field_name}/;    return 0 if $name =~ /$REG{UNSAFE_field_name}/;
277      $body = $self->_field_body ($body, $name);
278    for my $field (@{$self->{field}}) {    for my $field (@{$self->{field}}) {
279      if ($field->{name} eq $name) {      if ($field->{name} eq $name) {
280        $field->{body} = $body;        $field->{body} = $body;
281        return $self;        return $body;
282      }      }
283    }    }
284    push @{$self->{field}}, {name => $name, body => $body};    push @{$self->{field}}, {name => $name, body => $body};
285    $self;    $body;
286  }  }
287    
288  =head2 $self->delete ($field_name, [$index])  =head2 $self->delete ($field_name, [$index])
289    
290  Deletes C<field> named as $field_name.  Deletes C<field> named as $field_name.
291  If $index is specified, only $index'th C<field> is deleted.  If $index is specified, only $index'th C<field> is deleted.
292    ($index of first field is C<1>, not C<0>.)
293  If not, ($index == 0), all C<field>s that have the C<field-name>  If not, ($index == 0), all C<field>s that have the C<field-name>
294  $field_name are deleted.  $field_name are deleted.
295    
# Line 291  sub count ($;$) { Line 335  sub count ($;$) {
335    $count;    $count;
336  }  }
337    
338    =head2 $self->rename ($field_name, [$index])
339    
340    Renames C<field> named as $field_name.
341    If $index is specified, only $index'th C<field> is renamed.
342    ($index of first field is C<1>, not C<0>.)
343    If not, ($index == 0), all C<field>s that have the C<field-name>
344    $field_name are renamed.
345    
346    =cut
347    
348    sub rename ($$$;$) {
349      my $self = shift;
350      my ($name, $newname, $index) = (lc shift, lc shift, shift);
351      my $i = 0;
352      croak "rename: new field-name contains of unsafe character: $newname"
353        if !$newname || $newname =~ /$REG{UNSAFE_field_name}/;
354      for my $field (@{$self->{field}}) {
355        if ($field->{name} eq $name) {
356          $i++;
357          if ($index == 0 || $i == $index) {
358            $field->{name} = $newname;
359            return $self if $i == $index;
360          }
361        }
362      }
363      $self;
364    }
365    
366  =head2 $self->stringify ([%option])  =head2 $self->stringify ([%option])
367    
368  Returns the C<header> as a string.  Returns the C<header> as a string.
# Line 303  sub stringify ($;%) { Line 375  sub stringify ($;%) {
375    my @ret;    my @ret;
376    $OPT{capitalize} ||= $self->{option}->{capitalize};    $OPT{capitalize} ||= $self->{option}->{capitalize};
377    $OPT{mail_from} ||= $self->{option}->{mail_from};    $OPT{mail_from} ||= $self->{option}->{mail_from};
378    push @ret, 'From '.$self->field ('mail-from') if $OPT{mail_from};    $OPT{output_bcc} ||= $self->{option}->{output_bcc};
379      $OPT{format} ||= $self->{option}->{format};
380      push @ret, 'From '.$self->field ('mail-from') if $OPT{mail_from}>0;
381    for my $field (@{$self->{field}}) {    for my $field (@{$self->{field}}) {
382      my $name = $field->{name};      my $name = $field->{name};
383      next unless $field->{name};      next unless $name;
384      next if !$OPT{mail_from} && $name eq 'mail-from';      next if $OPT{mail_from}<0 && $name eq 'mail-from';
385        next if $OPT{output_bcc}<0 && ($name eq 'bcc' || $name eq 'resent-bcc');
386        my $fbody;
387        if (ref $field->{body}) {
388          $fbody = $field->{body}->stringify (format => $OPT{format});
389        } else {
390          $fbody = $field->{body};
391        }
392        next unless $fbody;
393        $fbody =~ s/\x0D([^\x09\x0A\x20])/\x0D\x20$1/g;
394        $fbody =~ s/\x0A([^\x09\x20])/\x0A\x20$1/g;
395      $name =~ s/((?:^|-)[a-z])/uc($1)/ge if $OPT{capitalize};      $name =~ s/((?:^|-)[a-z])/uc($1)/ge if $OPT{capitalize};
396      push @ret, $name.': '.$self->fold ($field->{body});      push @ret, $name.': '.$self->fold ($fbody);
397    }    }
398    my $ret = join ("\n", @ret);    my $ret = join ("\n", @ret);
399    $ret? $ret."\n": "";    $ret? $ret."\n": "";
400  }  }
401    
402  =head2 $self->get_option ($option_name)  =head2 $self->option ($option_name, [$option_value])
   
 Returns value of the option.  
403    
404  =head2 $self->set_option ($option_name, $option_value)  Set/gets new value of the option.
   
 Set new value of the option.  
405    
406  =cut  =cut
407    
408  sub get_option ($$) {  sub option ($$;$) {
   my $self = shift;  
   my ($name) = @_;  
   $self->{option}->{$name};  
 }  
 sub set_option ($$$) {  
409    my $self = shift;    my $self = shift;
410    my ($name, $value) = @_;    my ($name, $value) = @_;
411    $self->{option}->{$name} = $value;    if (defined $value) {
412    $self;      $self->{option}->{$name} = $value;
413        if ($name eq 'format') {
414          for my $f (@{$self->{field}}) {
415            if (ref $f) {
416              $f->option (format => $value);
417            }
418          }
419        }
420      }
421      $self->{option}->{$name};
422  }  }
423    
424  sub field_type ($$;$) {  sub field_type ($$;$) {
# Line 345  sub field_type ($$;$) { Line 429  sub field_type ($$;$) {
429      $self->{option}->{field_type}->{$field_name} = $new_field_type;      $self->{option}->{field_type}->{$field_name} = $new_field_type;
430    }    }
431    $self->{option}->{field_type}->{$field_name}    $self->{option}->{field_type}->{$field_name}
432    || $self->{option}->{field_type}->{_DEFAULT};    || $self->{option}->{field_type}->{':DEFAULT'};
433  }  }
434    
435  sub _delete_empty_field ($) {  sub _delete_empty_field ($) {
# Line 376  sub fold ($$;$) { Line 460  sub fold ($$;$) {
460       # next split a whitespace       # next split a whitespace
461       # else we are looking at a single word and probably don't want to split       # else we are looking at a single word and probably don't want to split
462       my $x = "";       my $x = "";
463       $x .= "$1\n    "       $x .= "$1\n "
464         while($string =~ s/^$REG{WSP}*(         while($string =~ s/^$REG{WSP}*(
465                            [^"]{$min,$max}?[\,\;]                            [^"]{$min,$max}?[\,\;]
466                            |[^"]{1,$max}$REG{WSP}                            |[^"]{1,$max}$REG{WSP}
Legend:
Removed from v.1.4  
changed lines
  Added in v.1.13
admin@suikawiki.org
 ViewVC Help
Powered by ViewVC 1.1.24