/[suikacvs]/messaging/manakai/lib/Message/Header.pm
Suika

Diff of /messaging/manakai/lib/Message/Header.pm

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

revision 1.7 by wakaba, Thu Mar 21 04:21:28 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,
   mail_from     => 0,  
50    field_type    => {':DEFAULT' => 'Message::Field::Unstructured'},    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  my @field_type_Structured = qw(cancel-lock
57    importance mime-version path precedence user-agent x-cite    importance mime-version path precedence x-cite
58    x-face x-mail-count x-msmail-priority x-priority x-uidl 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      envelope-to
63    errors-to fcc from mail-followup-to mail-followup-cc mail-from reply-to resent-bcc    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
# Line 67  my @field_type_Date = qw(date date-recei Line 71  my @field_type_Date = qw(date date-recei
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 see-also supersedes);    references resent-message-id see-also supersedes);
76  for (@field_type_MsgID)  for (@field_type_MsgID)
77    {$DEFAULT{field_type}->{$_} = 'Message::Field::MsgID'}    {$DEFAULT{field_type}->{$_} = 'Message::Field::MsgID'}
78  for (qw(received x-received))  for (qw(received x-received))
79    {$DEFAULT{field_type}->{$_} = 'Message::Field::Received'}    {$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  for (qw(accept accept-charset accept-encoding accept-language
85    content-disposition content-language    content-language
86    content-transfer-encoding content-type encrypted followup-to keywords newsgroups    content-transfer-encoding encrypted followup-to keywords
87    x-brother x-daughter x-face-type x-respect x-moe    list-archive list-digest list-help list-owner
88    x-syster x-wife))    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'}    {$DEFAULT{field_type}->{$_} = 'Message::Field::CSV'}
91  my @field_type_URI = qw(list-archive list-help list-owner  for (qw(content-alias content-base content-location location referer
92    list-post list-subscribe list-unsubscribe uri url x-home-page x-http_referer    url x-home-page x-http_referer
93    x-info x-pgp-key x-ml-url x-uri x-url x-web);    x-info x-pgp-key x-ml-url x-uri x-url x-web))
94  for (@field_type_URI)    {$DEFAULT{field_type}->{$_} = 'Message::Field::URI'}
   {$DEFAULT{field_type}->{$_} = 'Message::Field::Structured'}  
95  for (qw(list-id))  for (qw(list-id))
96    {$DEFAULT{field_type}->{$_} = 'Message::Field::Structured'}    {$DEFAULT{field_type}->{$_} = 'Message::Field::Structured'}
97  for (qw(content-description subject title x-nsubject))  for (qw(subject title x-nsubject))
98    {$DEFAULT{field_type}->{$_} = 'Message::Field::Subject'}    {$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 118  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 153  sub field ($$) { Line 167  sub field ($$) {
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 186  sub _field_body ($$$) { Line 213  sub _field_body ($$$) {
213              || $self->{option}->{field_type}->{':DEFAULT'};              || $self->{option}->{field_type}->{':DEFAULT'};
214      eval "require $type";      eval "require $type";
215      unless ($body) {      unless ($body) {
216        $body = $type->new (field_name => $name);        $body = $type->new (field_name => $name, format => $self->{option}->{format});
217      } else {      } else {
218        $body = $type->parse ($body, field_name => $name);        $body = $type->parse ($body, field_name => $name,
219            format => $self->{option}->{format});
220      }      }
221    }    }
222    $body;    $body;
# Line 216  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    $body = $self->_field_body ($body, $name);    $body = $self->_field_body ($body, $name);
253    push @{$self->{field}}, {name => $name, body => $body};    if ($option{prepend}) {
254        unshift @{$self->{field}}, {name => $name, body => $body};
255      } else {
256        push @{$self->{field}}, {name => $name, body => $body};
257      }
258    $body;    $body;
259  }  }
260    
# Line 239  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 298  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 310  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      my $fbody = scalar $field->{body};      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;      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 ($fbody);      push @ret, $name.': '.$self->fold ($fbody);
395    }    }
# Line 324  sub stringify ($;%) { Line 397  sub stringify ($;%) {
397    $ret? $ret."\n": "";    $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 ($$;$) {
   my $self = shift;  
   my ($name) = @_;  
   $self->{option}->{$name};  
 }  
 sub set_option ($$$) {  
407    my $self = shift;    my $self = shift;
408    my ($name, $value) = @_;    my ($name, $value) = @_;
409    $self->{option}->{$name} = $value;    if (defined $value) {
410    $self;      $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};
420  }  }
421    
422  sub field_type ($$;$) {  sub field_type ($$;$) {
# Line 385  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}
Legend:
Removed from v.1.7  
changed lines
  Added in v.1.12
[email protected]
 ViewVC Help
Powered by ViewVC 1.1.24