/[suikacvs]/test/cvs
Suika

Diff of /test/cvs

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

revision 1.1 by wakaba, Wed Mar 13 12:51:11 2002 UTC revision 1.11 by wakaba, Tue Mar 26 15:19:53 2002 UTC
# 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      mail_from     => -1,
52      output_bcc    => -1,
53      parse_all     => -1,
54  );  );
55    my @field_type_Structured = qw(cancel-lock
56      importance mime-version path precedence x-cite
57      x-face x-mail-count x-msmail-priority x-priority x-uidl xref);
58    for (@field_type_Structured)
59      {$DEFAULT{field_type}->{$_} = 'Message::Field::Structured'}
60    my @field_type_Address = qw(approved bcc cc delivered-to disposition-notification-to
61      envelope-to
62      errors-to fcc from mail-followup-to mail-followup-cc mail-from reply-to resent-bcc
63      resent-cc resent-to resent-from resent-sender return-path
64      return-receipt-to sender to x-approved x-beenthere
65      x-complaints-to x-envelope-from x-envelope-sender
66      x-envelope-to x-ml-address x-ml-command x-ml-to x-nfrom x-nto);
67    for (@field_type_Address)
68      {$DEFAULT{field_type}->{$_} = 'Message::Field::Address'}
69    my @field_type_Date = qw(date date-received delivery-date expires
70      expire-date nntp-posting-date posted reply-by resent-date x-tcup-date);
71    for (@field_type_Date)
72      {$DEFAULT{field_type}->{$_} = 'Message::Field::Date'}
73    my @field_type_MsgID = qw(content-id in-reply-to message-id
74      references resent-message-id see-also supersedes);
75    for (@field_type_MsgID)
76      {$DEFAULT{field_type}->{$_} = 'Message::Field::MsgID'}
77    for (qw(received x-received))
78      {$DEFAULT{field_type}->{$_} = 'Message::Field::Received'}
79    $DEFAULT{field_type}->{'content-type'} = 'Message::Field::ContentType';
80    $DEFAULT{field_type}->{'content-disposition'} = 'Message::Field::ContentDisposition';
81    for (qw(x-face-type))
82      {$DEFAULT{field_type}->{$_} = 'Message::Field::ValueParams'}
83    for (qw(accept accept-charset accept-encoding accept-language
84      content-language
85      content-transfer-encoding encrypted followup-to keywords newsgroups
86      x-brother x-daughter x-respect x-moe x-syster x-wife))
87      {$DEFAULT{field_type}->{$_} = 'Message::Field::CSV'}
88    my @field_type_URI = qw(list-archive list-help list-owner
89      list-post list-subscribe list-unsubscribe uri url x-home-page x-http_referer
90      x-info x-pgp-key x-ml-url x-uri x-url x-web);
91    for (@field_type_URI)
92      {$DEFAULT{field_type}->{$_} = 'Message::Field::Structured'}
93    for (qw(list-id))
94      {$DEFAULT{field_type}->{$_} = 'Message::Field::Structured'}
95    for (qw(subject title x-nsubject))
96      {$DEFAULT{field_type}->{$_} = 'Message::Field::Subject'}
97    for (qw(list-software user-agent server))
98      {$DEFAULT{field_type}->{$_} = 'Message::Field::UA'}
99    
100  =head2 Message::Header->new ([%option])  =head2 Message::Header->new ([%option])
101    
# Line 79  sub parse ($$;%) { Line 126  sub parse ($$;%) {
126    $header =~ s/\x0D?\x0A$REG{WSP}+/\x20/gos;    ## unfold    $header =~ s/\x0D?\x0A$REG{WSP}+/\x20/gos;    ## unfold
127    for my $field (split /\x0D?\x0A/, $header) {    for my $field (split /\x0D?\x0A/, $header) {
128      if ($field =~ /$REG{M_fromline}/) {      if ($field =~ /$REG{M_fromline}/) {
129        push @{$self->{field}}, {name => 'mail-from', body => $1};        my $body = $1;
130          $body = $self->_field_body ($body, 'mail-from')
131            if $self->{option}->{parse_all}>0;
132          push @{$self->{field}}, {name => 'mail-from', body => $body};
133      } elsif ($field =~ /$REG{M_field}/) {      } elsif ($field =~ /$REG{M_field}/) {
134        my ($name, $body) = ($1, $2);        my ($name, $body) = (lc $1, $2);
135        $name =~ s/$REG{WSP}+$//;        $name =~ s/$REG{WSP}+$//;
136        $body =~ s/$REG{WSP}+$//;        $body =~ s/$REG{WSP}+$//;
137        push @{$self->{field}}, {name => lc $name, body => $body};        $body = $self->_field_body ($body, $name) if $self->{option}->{parse_all}>0;
138          push @{$self->{field}}, {name => $name, body => $body};
139      }      }
140    }    }
141    $self;    $self;
# Line 106  sub field ($$) { Line 157  sub field ($$) {
157    for my $field (@{$self->{field}}) {    for my $field (@{$self->{field}}) {
158      if ($field->{name} eq $name) {      if ($field->{name} eq $name) {
159        unless (wantarray) {        unless (wantarray) {
160            $field->{body} = $self->_field_body ($field->{body}, $name);
161          return $field->{body};          return $field->{body};
162        } else {        } else {
163            $field->{body} = $self->_field_body ($field->{body}, $name);
164          push @ret, $field->{body};          push @ret, $field->{body};
165        }        }
166      }      }
167    }    }
168      if ($#ret < 0) {
169        return $self->add ($name);
170      }
171    @ret;    @ret;
172  }  }
173    
174    sub field_exist ($$) {
175      my $self = shift;
176      my $name = lc shift;
177      my @ret;
178      for my $field (@{$self->{field}}) {
179        return 1 if ($field->{name} eq $name);
180      }
181      0;
182    }
183    
184    =head2 $self->field_name ($index)
185    
186    Returns C<field-name> of $index'th C<field>.
187    
188    =head2 $self->field_body ($index)
189    
190    Returns C<field-body> of $index'th C<field>.
191    
192    =cut
193    
194    sub field_name ($$) {
195      my $self = shift;
196      $self->{field}->[shift]->{name};
197    }
198    sub field_body ($$) {
199      my $self = shift;
200      my $i = shift;
201      $self->{field}->[$i]->{body}
202       = $self->_field_body ($self->{field}->[$i]->{body}, $self->{field}->[$i]->{name});
203      $self->{field}->[$i]->{body};
204    }
205    
206    sub _field_body ($$$) {
207      my $self = shift;
208      my ($body, $name) = @_;
209      unless (ref $body) {
210        my $type = $self->{option}->{field_type}->{$name}
211                || $self->{option}->{field_type}->{':DEFAULT'};
212        eval "require $type";
213        unless ($body) {
214          $body = $type->new (field_name => $name);
215        } else {
216          $body = $type->parse ($body, field_name => $name);
217        }
218      }
219      $body;
220    }
221    
222  =head2 $self->field_name_list ()  =head2 $self->field_name_list ()
223    
224  Returns list of all C<field-name>s.  (Even if there are two  Returns list of all C<field-name>s.  (Even if there are two
# Line 137  If you don't want duplicated C<field>s, Line 241  If you don't want duplicated C<field>s,
241    
242  =cut  =cut
243    
244  sub add ($$$) {  sub add ($$;$%) {
245    my $self = shift;    my $self = shift;
246    my ($name, $body) = (lc shift, shift);    my ($name, $body) = (lc shift, shift);
247      my %option = @_;
248    return 0 if $name =~ /$REG{UNSAFE_field_name}/;    return 0 if $name =~ /$REG{UNSAFE_field_name}/;
249    push @{$self->{field}}, {name => $name, body => $body};    $body = $self->_field_body ($body, $name);
250    $self;    if ($option{prepend}) {
251        unshift @{$self->{field}}, {name => $name, body => $body};
252      } else {
253        push @{$self->{field}}, {name => $name, body => $body};
254      }
255      $body;
256  }  }
257    
258  =head2 $self->relace ($field_name, $field_body)  =head2 $self->relace ($field_name, $field_body)
# Line 159  sub replace ($$$) { Line 269  sub replace ($$$) {
269    my $self = shift;    my $self = shift;
270    my ($name, $body) = (lc shift, shift);    my ($name, $body) = (lc shift, shift);
271    return 0 if $name =~ /$REG{UNSAFE_field_name}/;    return 0 if $name =~ /$REG{UNSAFE_field_name}/;
272      $body = $self->_field_body ($body, $name);
273    for my $field (@{$self->{field}}) {    for my $field (@{$self->{field}}) {
274      if ($field->{name} eq $name) {      if ($field->{name} eq $name) {
275        $field->{body} = $body;        $field->{body} = $body;
276        return $self;        return $body;
277      }      }
278    }    }
279    push @{$self->{field}}, {name => $name, body => $body};    push @{$self->{field}}, {name => $name, body => $body};
280    $self;    $body;
281  }  }
282    
283  =head2 $self->delete ($field_name, [$index])  =head2 $self->delete ($field_name, [$index])
# Line 194  sub delete ($$;$) { Line 305  sub delete ($$;$) {
305    $self;    $self;
306  }  }
307    
308  =head2 $self->count ($field_name)  =head2 $self->count ([$field_name])
309    
310  Returns the number of times the given C<field> appears.  Returns the number of times the given C<field> appears.
311    If no $field_name is given, returns the number
312    of fields.  (Same as $#$self+1)
313    
314  =cut  =cut
315    
316  sub count ($$) {  sub count ($;$) {
317    my $self = shift;    my $self = shift;
318    my ($name) = (lc shift);    my ($name) = (lc shift);
319      unless ($name) {
320        $self->_delete_empty_field ();
321        return $#{$self->{field}}+1;
322      }
323    my $count = 0;    my $count = 0;
324    for my $field (@{$self->{field}}) {    for my $field (@{$self->{field}}) {
325      if ($field->{name} eq $name) {      if ($field->{name} eq $name) {
# Line 224  sub stringify ($;%) { Line 341  sub stringify ($;%) {
341    my @ret;    my @ret;
342    $OPT{capitalize} ||= $self->{option}->{capitalize};    $OPT{capitalize} ||= $self->{option}->{capitalize};
343    $OPT{mail_from} ||= $self->{option}->{mail_from};    $OPT{mail_from} ||= $self->{option}->{mail_from};
344    push @ret, 'From '.$self->field ('mail-from') if $OPT{mail_from};    $OPT{output_bcc} ||= $self->{option}->{output_bcc};
345      push @ret, 'From '.$self->field ('mail-from') if $OPT{mail_from}>0;
346    for my $field (@{$self->{field}}) {    for my $field (@{$self->{field}}) {
347      my $name = $field->{name};      my $name = $field->{name};
348      next unless $field->{name};      next unless $name;
349      next if !$OPT{mail_from} && $name eq 'mail-from';      next if $OPT{mail_from}<0 && $name eq 'mail-from';
350        next if $OPT{output_bcc}<0 && ($name eq 'bcc' || $name eq 'resent-bcc');
351        my $fbody = scalar $field->{body};
352        next unless $fbody;
353        $fbody =~ s/\x0D([^\x09\x0A\x20])/\x0D\x20$1/g;
354        $fbody =~ s/\x0A([^\x09\x20])/\x0A\x20$1/g;
355      $name =~ s/((?:^|-)[a-z])/uc($1)/ge if $OPT{capitalize};      $name =~ s/((?:^|-)[a-z])/uc($1)/ge if $OPT{capitalize};
356      push @ret, $name.': '.$self->fold ($field->{body});      push @ret, $name.': '.$self->fold ($fbody);
357    }    }
358    join "\n", @ret;    my $ret = join ("\n", @ret);
359      $ret? $ret."\n": "";
360  }  }
361    
362  =head2 $self->get_option ($option_name)  =head2 $self->get_option ($option_name)
# Line 257  sub set_option ($$$) { Line 381  sub set_option ($$$) {
381    $self;    $self;
382  }  }
383    
384    sub field_type ($$;$) {
385      my $self = shift;
386      my $field_name = shift;
387      my $new_field_type = shift;
388      if ($new_field_type) {
389        $self->{option}->{field_type}->{$field_name} = $new_field_type;
390      }
391      $self->{option}->{field_type}->{$field_name}
392      || $self->{option}->{field_type}->{':DEFAULT'};
393    }
394    
395  sub _delete_empty_field ($) {  sub _delete_empty_field ($) {
396    my $self = shift;    my $self = shift;
397    my @ret;    my @ret;
# Line 285  sub fold ($$;$) { Line 420  sub fold ($$;$) {
420       # next split a whitespace       # next split a whitespace
421       # 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
422       my $x = "";       my $x = "";
423       $x .= "$1\n    "       $x .= "$1\n "
424         while($string =~ s/^$REG{WSP}*(         while($string =~ s/^$REG{WSP}*(
425                            [^"]{$min,$max}?[\,\;]                            [^"]{$min,$max}?[\,\;]
426                            |[^"]{1,$max}$REG{WSP}                            |[^"]{1,$max}$REG{WSP}
# Line 308  sub fold ($$;$) { Line 443  sub fold ($$;$) {
443    use Message::Header;    use Message::Header;
444    my $header = Message::Header->parse ($header);    my $header = Message::Header->parse ($header);
445        
446    for my $field (@$header) {    ## Next sample is better.
447      print $field->{name}, "\t=> ", $field->{body}, "\n";    #for my $field (@$header) {
448      #  print $field->{name}, "\t=> ", $field->{body}, "\n";
449      #}
450      
451      for my $i (0..$#$header) {
452        print $header->field_name ($i), "\t=> ", $header->field_body ($i), "\n";
453    }    }
454        
455        
456    ## Make simple header    ## Make simple header
457        
458      use Message::Header;
459    use Message::Field::Address;    use Message::Field::Address;
460    my $header = new Message::Header;    my $header = new Message::Header;
461        
# Line 351  Boston, MA 02111-1307, USA. Line 492  Boston, MA 02111-1307, USA.
492  =head1 CHANGE  =head1 CHANGE
493    
494  See F<ChangeLog>.  See F<ChangeLog>.
495    $Date$
496    
497  =cut  =cut
498    
Legend:
Removed from v.1.1  
changed lines
  Added in v.1.11
admin@suikawiki.org
 ViewVC Help
Powered by ViewVC 1.1.24