/[suikacvs]/test/cvs
Suika

Diff of /test/cvs

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

revision 1.2 by wakaba, Wed Mar 13 13:06:47 2002 UTC revision 1.12 by wakaba, Sun Mar 31 13:12:41 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      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
57      importance mime-version path precedence x-cite
58      x-face x-mail-count x-msmail-priority x-priority x-uidl xref);
59    for (@field_type_Structured)
60      {$DEFAULT{field_type}->{$_} = 'Message::Field::Structured'}
61    my @field_type_Address = qw(approved bcc cc delivered-to disposition-notification-to
62      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
65      return-receipt-to sender to x-approved x-beenthere
66      x-complaints-to x-envelope-from x-envelope-sender
67      x-envelope-to x-ml-address x-ml-command x-ml-to x-nfrom x-nto);
68    for (@field_type_Address)
69      {$DEFAULT{field_type}->{$_} = 'Message::Field::Address'}
70    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);
72    for (@field_type_Date)
73      {$DEFAULT{field_type}->{$_} = 'Message::Field::Date'}
74    my @field_type_MsgID = qw(article-updates content-id in-reply-to message-id
75      references resent-message-id see-also supersedes);
76    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'}
97    for (qw(subject title x-nsubject))
98      {$DEFAULT{field_type}->{$_} = 'Message::Field::Subject'}
99    for (qw(list-software user-agent server))
100      {$DEFAULT{field_type}->{$_} = 'Message::Field::UA'}
101    
102  =head2 Message::Header->new ([%option])  =head2 Message::Header->new ([%option])
103    
# Line 79  sub parse ($$;%) { Line 128  sub parse ($$;%) {
128    $header =~ s/\x0D?\x0A$REG{WSP}+/\x20/gos;    ## unfold    $header =~ s/\x0D?\x0A$REG{WSP}+/\x20/gos;    ## unfold
129    for my $field (split /\x0D?\x0A/, $header) {    for my $field (split /\x0D?\x0A/, $header) {
130      if ($field =~ /$REG{M_fromline}/) {      if ($field =~ /$REG{M_fromline}/) {
131        push @{$self->{field}}, {name => 'mail-from', body => $1};        my $body = $1;
132          $body = $self->_field_body ($body, 'mail-from')
133            if $self->{option}->{parse_all}>0;
134          push @{$self->{field}}, {name => 'mail-from', body => $body};
135      } elsif ($field =~ /$REG{M_field}/) {      } elsif ($field =~ /$REG{M_field}/) {
136        my ($name, $body) = ($1, $2);        my ($name, $body) = (lc $1, $2);
137        $name =~ s/$REG{WSP}+$//;        $name =~ s/$REG{WSP}+$//;
138        $body =~ s/$REG{WSP}+$//;        $body =~ s/$REG{WSP}+$//;
139        push @{$self->{field}}, {name => lc $name, body => $body};        $body = $self->_field_body ($body, $name) if $self->{option}->{parse_all}>0;
140          push @{$self->{field}}, {name => $name, body => $body};
141      }      }
142    }    }
143    $self;    $self;
# Line 106  sub field ($$) { Line 159  sub field ($$) {
159    for my $field (@{$self->{field}}) {    for my $field (@{$self->{field}}) {
160      if ($field->{name} eq $name) {      if ($field->{name} eq $name) {
161        unless (wantarray) {        unless (wantarray) {
162            $field->{body} = $self->_field_body ($field->{body}, $name);
163          return $field->{body};          return $field->{body};
164        } else {        } else {
165            $field->{body} = $self->_field_body ($field->{body}, $name);
166          push @ret, $field->{body};          push @ret, $field->{body};
167        }        }
168      }      }
169    }    }
170      if ($#ret < 0) {
171        return $self->add ($name);
172      }
173    @ret;    @ret;
174  }  }
175    
176    sub field_exist ($$) {
177      my $self = shift;
178      my $name = lc shift;
179      my @ret;
180      for my $field (@{$self->{field}}) {
181        return 1 if ($field->{name} eq $name);
182      }
183      0;
184    }
185    
186  =head2 $self->field_name ($index)  =head2 $self->field_name ($index)
187    
188  Returns C<field-name> of $index'th C<field>.  Returns C<field-name> of $index'th C<field>.
# Line 131  sub field_name ($$) { Line 199  sub field_name ($$) {
199  }  }
200  sub field_body ($$) {  sub field_body ($$) {
201    my $self = shift;    my $self = shift;
202    $self->{field}->[shift]->{body};    my $i = shift;
203      $self->{field}->[$i]->{body}
204       = $self->_field_body ($self->{field}->[$i]->{body}, $self->{field}->[$i]->{name});
205      $self->{field}->[$i]->{body};
206    }
207    
208    sub _field_body ($$$) {
209      my $self = shift;
210      my ($body, $name) = @_;
211      unless (ref $body) {
212        my $type = $self->{option}->{field_type}->{$name}
213                || $self->{option}->{field_type}->{':DEFAULT'};
214        eval "require $type";
215        unless ($body) {
216          $body = $type->new (field_name => $name, format => $self->{option}->{format});
217        } else {
218          $body = $type->parse ($body, field_name => $name,
219            format => $self->{option}->{format});
220        }
221      }
222      $body;
223  }  }
224    
225  =head2 $self->field_name_list ()  =head2 $self->field_name_list ()
# Line 156  If you don't want duplicated C<field>s, Line 244  If you don't want duplicated C<field>s,
244    
245  =cut  =cut
246    
247  sub add ($$$) {  sub add ($$;$%) {
248    my $self = shift;    my $self = shift;
249    my ($name, $body) = (lc shift, shift);    my ($name, $body) = (lc shift, shift);
250      my %option = @_;
251    return 0 if $name =~ /$REG{UNSAFE_field_name}/;    return 0 if $name =~ /$REG{UNSAFE_field_name}/;
252    push @{$self->{field}}, {name => $name, body => $body};    $body = $self->_field_body ($body, $name);
253    $self;    if ($option{prepend}) {
254        unshift @{$self->{field}}, {name => $name, body => $body};
255      } else {
256        push @{$self->{field}}, {name => $name, body => $body};
257      }
258      $body;
259  }  }
260    
261  =head2 $self->relace ($field_name, $field_body)  =head2 $self->relace ($field_name, $field_body)
# Line 178  sub replace ($$$) { Line 272  sub replace ($$$) {
272    my $self = shift;    my $self = shift;
273    my ($name, $body) = (lc shift, shift);    my ($name, $body) = (lc shift, shift);
274    return 0 if $name =~ /$REG{UNSAFE_field_name}/;    return 0 if $name =~ /$REG{UNSAFE_field_name}/;
275      $body = $self->_field_body ($body, $name);
276    for my $field (@{$self->{field}}) {    for my $field (@{$self->{field}}) {
277      if ($field->{name} eq $name) {      if ($field->{name} eq $name) {
278        $field->{body} = $body;        $field->{body} = $body;
279        return $self;        return $body;
280      }      }
281    }    }
282    push @{$self->{field}}, {name => $name, body => $body};    push @{$self->{field}}, {name => $name, body => $body};
283    $self;    $body;
284  }  }
285    
286  =head2 $self->delete ($field_name, [$index])  =head2 $self->delete ($field_name, [$index])
287    
288  Deletes C<field> named as $field_name.  Deletes C<field> named as $field_name.
289  If $index is specified, only $index'th C<field> is deleted.  If $index is specified, only $index'th C<field> is deleted.
290    ($index of first field is C<1>, not C<0>.)
291  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>
292  $field_name are deleted.  $field_name are deleted.
293    
# Line 237  sub count ($;$) { Line 333  sub count ($;$) {
333    $count;    $count;
334  }  }
335    
336    =head2 $self->rename ($field_name, [$index])
337    
338    Renames C<field> named as $field_name.
339    If $index is specified, only $index'th C<field> is renamed.
340    ($index of first field is C<1>, not C<0>.)
341    If not, ($index == 0), all C<field>s that have the C<field-name>
342    $field_name are renamed.
343    
344    =cut
345    
346    sub rename ($$$;$) {
347      my $self = shift;
348      my ($name, $newname, $index) = (lc shift, lc shift, shift);
349      my $i = 0;
350      croak "rename: new field-name contains of unsafe character: $newname"
351        if !$newname || $newname =~ /$REG{UNSAFE_field_name}/;
352      for my $field (@{$self->{field}}) {
353        if ($field->{name} eq $name) {
354          $i++;
355          if ($index == 0 || $i == $index) {
356            $field->{name} = $newname;
357            return $self if $i == $index;
358          }
359        }
360      }
361      $self;
362    }
363    
364  =head2 $self->stringify ([%option])  =head2 $self->stringify ([%option])
365    
366  Returns the C<header> as a string.  Returns the C<header> as a string.
# Line 249  sub stringify ($;%) { Line 373  sub stringify ($;%) {
373    my @ret;    my @ret;
374    $OPT{capitalize} ||= $self->{option}->{capitalize};    $OPT{capitalize} ||= $self->{option}->{capitalize};
375    $OPT{mail_from} ||= $self->{option}->{mail_from};    $OPT{mail_from} ||= $self->{option}->{mail_from};
376    push @ret, 'From '.$self->field ('mail-from') if $OPT{mail_from};    $OPT{output_bcc} ||= $self->{option}->{output_bcc};
377      $OPT{format} ||= $self->{option}->{format};
378      push @ret, 'From '.$self->field ('mail-from') if $OPT{mail_from}>0;
379    for my $field (@{$self->{field}}) {    for my $field (@{$self->{field}}) {
380      my $name = $field->{name};      my $name = $field->{name};
381      next unless $field->{name};      next unless $name;
382      next if !$OPT{mail_from} && $name eq 'mail-from';      next if $OPT{mail_from}<0 && $name eq 'mail-from';
383        next if $OPT{output_bcc}<0 && ($name eq 'bcc' || $name eq 'resent-bcc');
384        my $fbody;
385        if (ref $field->{body}) {
386          $fbody = $field->{body}->stringify (format => $OPT{format});
387        } else {
388          $fbody = $field->{body};
389        }
390        next unless $fbody;
391        $fbody =~ s/\x0D([^\x09\x0A\x20])/\x0D\x20$1/g;
392        $fbody =~ s/\x0A([^\x09\x20])/\x0A\x20$1/g;
393      $name =~ s/((?:^|-)[a-z])/uc($1)/ge if $OPT{capitalize};      $name =~ s/((?:^|-)[a-z])/uc($1)/ge if $OPT{capitalize};
394      push @ret, $name.': '.$self->fold ($field->{body});      push @ret, $name.': '.$self->fold ($fbody);
395    }    }
396    join "\n", @ret;    my $ret = join ("\n", @ret);
397      $ret? $ret."\n": "";
398  }  }
399    
400  =head2 $self->get_option ($option_name)  =head2 $self->option ($option_name, [$option_value])
   
 Returns value of the option.  
   
 =head2 $self->set_option ($option_name, $option_value)  
401    
402  Set new value of the option.  Set/gets new value of the option.
403    
404  =cut  =cut
405    
406  sub get_option ($$) {  sub option ($$;$) {
407    my $self = shift;    my $self = shift;
408    my ($name) = @_;    my ($name, $value) = @_;
409      if (defined $value) {
410        $self->{option}->{$name} = $value;
411        if ($name eq 'format') {
412          for my $f (@{$self->{field}}) {
413            if (ref $f) {
414              $f->option (format => $value);
415            }
416          }
417        }
418      }
419    $self->{option}->{$name};    $self->{option}->{$name};
420  }  }
421  sub set_option ($$$) {  
422    sub field_type ($$;$) {
423    my $self = shift;    my $self = shift;
424    my ($name, $value) = @_;    my $field_name = shift;
425    $self->{option}->{$name} = $value;    my $new_field_type = shift;
426    $self;    if ($new_field_type) {
427        $self->{option}->{field_type}->{$field_name} = $new_field_type;
428      }
429      $self->{option}->{field_type}->{$field_name}
430      || $self->{option}->{field_type}->{':DEFAULT'};
431  }  }
432    
433  sub _delete_empty_field ($) {  sub _delete_empty_field ($) {
# Line 310  sub fold ($$;$) { Line 458  sub fold ($$;$) {
458       # next split a whitespace       # next split a whitespace
459       # 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
460       my $x = "";       my $x = "";
461       $x .= "$1\n    "       $x .= "$1\n "
462         while($string =~ s/^$REG{WSP}*(         while($string =~ s/^$REG{WSP}*(
463                            [^"]{$min,$max}?[\,\;]                            [^"]{$min,$max}?[\,\;]
464                            |[^"]{1,$max}$REG{WSP}                            |[^"]{1,$max}$REG{WSP}
# Line 382  Boston, MA 02111-1307, USA. Line 530  Boston, MA 02111-1307, USA.
530  =head1 CHANGE  =head1 CHANGE
531    
532  See F<ChangeLog>.  See F<ChangeLog>.
533    $Date$
534    
535  =cut  =cut
536    
Legend:
Removed from v.1.2  
changed lines
  Added in v.1.12
admin@suikawiki.org
 ViewVC Help
Powered by ViewVC 1.1.24