/[suikacvs]/messaging/manakai/lib/Message/Field/Subject.pm
Suika

Diff of /messaging/manakai/lib/Message/Field/Subject.pm

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

revision 1.8 by wakaba, Wed Jul 17 00:33:29 2002 UTC revision 1.9 by wakaba, Thu Aug 1 06:42:38 2002 UTC
# Line 8  message header C<Subject:> field body Line 8  message header C<Subject:> field body
8    
9  package Message::Field::Subject;  package Message::Field::Subject;
10  use strict;  use strict;
11  use vars qw(@ISA %REG $VERSION);  use vars qw(%DEFAULT @ISA %REG $VERSION);
12  $VERSION=do{my @r=(q$Revision$=~/\d+/g);sprintf "%d."."%02d" x $#r,@r};  $VERSION=do{my @r=(q$Revision$=~/\d+/g);sprintf "%d."."%02d" x $#r,@r};
13  require Message::Util;  require Message::Field::Structured;
14  require Message::Field::Unstructured;  push @ISA, q(Message::Field::Structured);
15  push @ISA, q(Message::Field::Unstructured);  
16  use overload '""' => sub {shift->stringify};  %REG = %Message::Util::REG;
17            $REG{news_control} = qr/^cmsg$REG{WSP}+/;
18  *REG = \%Message::Util::REG;          $REG{prefix_fwd} = qr/(?i)Fwd?/;
19  $REG{re} = qr/(?:[Rr][Ee]|[Ss][Vv])\^?\[?[0-9]*\]?[:>]/;          $REG{prefix_list} = qr/[(\[][A-Za-z0-9._-]+[\x20:-]\d+[)\]]/;
20  $REG{fwd} = qr/[Ff][Ww][Dd]?:/;          $REG{M_prefix_list} = qr/[(\[]([A-Za-z0-9._-]+)[\x20:-](\d+)[)\]]/;
21  $REG{ml} = qr/[(\[][A-Za-z0-9._-]+[\x20:-][0-9]+[)\]]/;          $REG{M_was_subject} = qr/\([Ww][Aa][Ss][:\x09\x20]$REG{FWS}(.+?)$REG{FWS}\)$REG{FWS}$/;
22  $REG{M_ml} = qr/[(\[]([A-Za-z0-9._-]+)[\x20:-]([0-9]+)[)\]]/;          $REG{message_from_subject} = qr/^$REG{FWS}(?i)Message from \S+$REG{FWS}$/;
23  $REG{prefix} = qr/(?:$REG{re}|$REG{fwd}|$REG{ml})(?:$REG{FWS}(?:$REG{re}|$REG{fwd}|$REG{ml}))*/;          if (defined $^V) {
24  $REG{M_control} = qr/^cmsg$REG{FWS}([\x00-\xFF]*)$/;            $REG{prefix_re} = qr/(?i)Re|Sv|Odp
25  $REG{M_was} = qr/\([Ww][Aa][Ss]:? ([\x00-\xFF]+)\)$REG{FWS}$/;              |\x{8FD4}   ## Hen
26              /x;
27              $REG{prefix_advertisement} = qr/
28                (?i)ADV?:
29                |[!\x{FF01}] $REG{FWS} \x{5E83}[\x{543F}\x{544A}] $REG{FWS} [!\x{FF01}]
30                    ## ! kou koku !
31                |[!\x{FF01}] $REG{FWS} [\x{9023}\x{F99A}]\x{7D61}\x{65B9}\x{6CD5}\x{7121}\x{3057}? $REG{FWS} [!\x{FF01}]
32                    ## ! ren raku hou hou nashi !
33                |\x{672A}\x{627F}\x{8AFE}\x{5E83}[\x{543F}\x{544A}][\x{203B}\x{0FBF}]
34                    ## mi shou daku kou koku *
35              /x;
36            } else {
37              $REG{prefix_re} = qr/(?i)Re|Sv/;
38              $REG{prefix_advertisement} = qr/(?i)ADV?:/;
39            }
40            $REG{prefix_general} = qr/((?:$REG{prefix_re}|$REG{prefix_fwd})\^?[\[\(]?\d*[\]\)]?[:>]$REG{FWS})+/x;
41            $REG{prefix_general_list} = qr/($REG{prefix_general}|$REG{FWS}$REG{prefix_list}$REG{FWS})+/x;
42    
43    ## Initialize of this class -- called by constructors
44    %DEFAULT = (
45            -_MEMBERS       => [qw/is list_count list_name news_control was_subject/],
46            -_METHODS       => [qw/as_plain_string is list_count list_name news_control was_subject value value_type/],
47            #encoding_after_encode
48            #encoding_before_decode
49            -format_news_control    => 'cmsg %s',
50            -format_prefix_fwd      => 'Fwd: %s',
51            -format_prefix_re       => 'Re: %s',
52            -format_was_subject     => '%s (was: %s)',
53            #field_param_name
54            #field_name
55            #field_ns
56            #format
57            #header_default_charset
58            #header_default_charset_input
59            #hook_encode_string
60            #hook_decode_string
61            -output_general_prefix  => 1,
62            -output_list_prefix     => 1,
63            -output_news_control    => 1,
64            -output_was_subject     => 1,   ## ["-"] 1*DIGIT
65            #parse_all
66            -parse_was_subject      => 1,
67            -use_general_prefix     => 1,
68            -use_list_prefix        => 0,
69            -use_message_from_subject       => 0,
70            -use_news_control       => 1,
71            -use_was_subject        => 1,
72            #value_type
73    );
74    
75  =head1 CONSTRUCTORS  =head1 CONSTRUCTORS
76    
77  The following methods construct new C<Message::Field::Subject> objects:  The following methods construct new objects:
78    
79  =over 4  =over 4
80    
# Line 36  The following methods construct new C<Me Line 84  The following methods construct new C<Me
84  sub _init ($;%) {  sub _init ($;%) {
85    my $self = shift;    my $self = shift;
86    my %options = @_;    my %options = @_;
   my %DEFAULT = (  
     #encoding_after_encode      ## Inherited  
     #encoding_before_decode     ## Inherited  
     -format_adv => 'ADV: %s',  
     -format_fwd => 'Fwd: %s',  
     -format_re  => 'Re: %s',  
     -format_was => '%s (was: %s)',  
     #hook_encode_string ## Inherited  
     #hook_decode_string ## Inherited  
     -prefix_cmsg        => 'cmsg ',  
     -regex_adv  => qr/(?i)ADV:/,  
     -regex_adv_check    => qr/^ADV:/,  
     -remove_ml_prefix   => 1,  
   );  
87    $self->SUPER::_init (%DEFAULT, %options);    $self->SUPER::_init (%DEFAULT, %options);
88        
89    unless ($self->{option}->{remove_ml_prefix}) {    #$self->{option}->{value_type}->{news_control} = ['Message::Field::UsenetControl',{}, [qw//]];
90      $REG{prefix} = qr/(?:$REG{re}|$REG{fwd})(?:$REG{FWS}(?:$REG{re}|$REG{fwd}))*/;    $self->{option}->{value_type}->{was_subject} = ['Message::Field::Subject',{},
91    }      [qw/format_news_control format_prefix_fwd format_prefix_re
92        format_was_subject output_general_prefix output_list_prefix
93        output_news_control output_was_subject parse_was_subject
94        use_general_prefix use_list_prefix use_news_control use_was_subject/]];
95  }  }
96    
97  =item $subject = Message::Field::Subject->new ([%options])  =item $subject = Message::Field::Subject->new ([%options])
# Line 76  given field body.  You might pass some o Line 113  given field body.  You might pass some o
113  sub parse ($$;%) {  sub parse ($$;%) {
114    my $class = shift;    my $class = shift;
115    my $self = bless {}, $class;    my $self = bless {}, $class;
116    my $field_body = shift;    my $body = shift;
117    $self->_init (@_);    $self->_init (@_);
118    if ($field_body =~ /$REG{M_control}/) {    my $option = $self->{option};
119      $self->{is_control} = 1;    ## Obsoleted control message    if ($option->{use_news_control} && $body =~ s/$REG{news_control}//) {
120      $self->{field_body} = $1;   ## TODO: passes to Message::Field::Control      $self->{news_control} = $body;
121      return $self;      return $self;
122    }    }
123    my %s = &{$self->{option}->{hook_decode_string}} ($self, $field_body,    my $value = '';
124      type => 'text'); $field_body = $s{value};      my %s = &{$self->{option}->{hook_decode_string}} ($self,
125    $field_body =~ s{^$REG{FWS}($REG{prefix})$REG{FWS}}{        $body,
126      my $prefix = $1;        type => 'text',
127      $self->{is_reply} = 1 if $prefix =~ /$REG{re}/;        charset   => $option->{encoding_before_decode},
128      $self->{is_foward} = 1 if $prefix =~ /$REG{fwd}/;      );
129      if ($prefix =~ /$REG{M_ml}/) {      if ($s{charset}) {  ## Convertion failed
130        ($self->{ml_name}, $self->{ml_count}) = ($1, $2);        $self->{_charset} = $s{charset};
131          $self->{value} = $s{value};
132          return $self;
133        } elsif (!$s{success}) {
134          $self->{_charset} = $self->{option}->{header_default_charset_input};
135          $self->{value} = $s{value};
136          return $self;
137        }
138        $value = $s{value};
139      #if (!$option->{parse_all}) {
140      #  $self->{value} = $value;
141      #  return $self;
142      #}
143      if ($option->{use_general_prefix}) {
144        if ($option->{use_list_prefix} && $value =~ s/^($REG{prefix_general_list})//x) {
145          my $prefix = $1;
146          $self->{is}->{reply} = 1 if $prefix =~ /$REG{prefix_re}/x;
147          $self->{is}->{foward} = 1 if $prefix =~ /$REG{prefix_fwd}/x;
148          ($self->{list_name}, $self->{list_count}) = ($1, $2)
149            if $prefix =~ /$REG{M_prefix_list}/x;
150        } elsif ($value =~ s/^($REG{prefix_general})//x) {
151          my $prefix = $1;
152          $self->{is}->{reply} = 1 if $prefix =~ /$REG{prefix_re}/x;
153          $self->{is}->{foward} = 1 if $prefix =~ /$REG{prefix_fwd}/x;
154      }      }
155      ''    } elsif ($option->{use_list_prefix} && $value =~ s/^$REG{FWS}$REG{M_prefix_list}(?:$REG{FWS}$REG{prefix_list})*$REG{FWS}//x) {
156    }ex;      ($self->{list_name}, $self->{list_count}) = ($1, $2);
157    $self->{is_adv} = 1 if $field_body =~ /$self->{option}->{regex_adv}/;    }
158    $field_body =~ s{$REG{FWS}$REG{M_was}}{    if ($option->{use_was_subject} && $value =~ s/$REG{M_was_subject}//) {
159      my $was = $1;      my $was = $1;
160      if ($self->{option}->{parse_was}) {      if ($option->{parse_was_subject}) {
161        $self->{was} = Message::Field::Subject->parse ($was);        my %option;
162        $self->{was}->{option} = {%{$self->{option}}};        for (keys %$option) {
163          ## WARNING: this does not support the cases that some of option          $option{ '-'.$_ } = Message::Util::make_clone ($option->{ $_ });
164          ## values are reference to something.        }
165          $self->{was_subject} = ref ($self)->parse ($was,
166            -hook_decode_string => sub { shift; (value => shift, @_) },
167            %option);
168      } else {      } else {
169        $self->{was} = $was;        $self->{was_subject} = $was;
170      }      }
171      ''    }
172    }ex;    if ($option->{use_message_from_subject} && $value =~ s/$REG{message_from_subject}//) {
173    $self->{field_body} = $field_body;      $self->{is}->{message_from_subject} = 1;
174      }
175      $self->{value} = $value;
176    $self;    $self;
177  }  }
178    
# Line 117  sub parse ($$;%) { Line 182  sub parse ($$;%) {
182    
183  =over 4  =over 4
184    
185    =cut
186    
187    sub value ($;$) {
188      my $self = shift;
189      my $v = shift;
190      if (defined $v) {
191        $self->{value} = $v;
192      }
193      $self->{value};
194    }
195    
196    sub list_name ($) { $_[0]->{list_name} }
197    sub list_count ($) { $_[0]->{list_count} }
198    
199  =item $body = $subject->stringify  =item $body = $subject->stringify
200    
201  Retruns subject field body as string.  String is encoded  Retruns subject field body as string.  String is encoded
# Line 125  for message if necessary. Line 204  for message if necessary.
204  =cut  =cut
205    
206  sub stringify ($;%) {  sub stringify ($;%) {
207    my $self = shift;  my %o = @_;    my $self = shift;
208    my %option = %{$self->{option}};    my %o = @_; my %option = %{$self->{option}};
209    for (grep {/^-/} keys %o) {$option{substr ($_, 1)} = $o{$_}}    for (grep {/^-/} keys %o) {$option{substr ($_, 1)} = $o{$_}}
210    if ($self->{is_control}) {    if ($option{use_news_control} && $option{output_news_control}
211      my $s = $self->{field_body};        && $self->{news_control}) {
212      $s = $option{prefix_cmsg}.$s if $s;      my $c = $self->{news_control};
213      return $s;      return '' unless length $c;
214    }      return sprintf $option{format_news_control}, $c;
   my %e = (value => $self->{field_body});  
   my $was = (ref $self->{was}? $self->{was}->as_plain_string: $self->{was});  
   if ($self->{is_reply}) {  
     $e{value} = sprintf $option{format_re}, $e{value};  
215    }    }
216    if ($self->{is_foward}) {    if ($self->{_charset}) {
217      $e{value} = sprintf $option{format_fwd}, $e{value};      return $self->{value};
218    }    } else {
219    if (length $was) {      my $value = $self->{value};
220      $e{value} = sprintf $option{format_was}, $e{value} => $was;      if ($option{use_general_prefix} && $option{output_general_prefix}) {
221    }        $value = sprintf $option{format_prefix_re}, $value if $self->{is}->{reply};
222    if ($self->{is_adv}        $value = sprintf $option{format_prefix_fwd}, $value if $self->{is}->{foward};
223     && $self->{field_body} !~ /$option{regex_adv_check}/) {      }
224      $e{value} = sprintf $option{format_adv}, $e{value};      if ($option{use_was_subject} && $option{output_was_subject} > 0) {
225          my $was;
226          if (ref $self->{was_subject}) {
227            my %opt = @_;
228            $opt{-output_was_subject} = $opt{output_was_subject}
229              unless defined $opt{-output_was_subject};
230            $opt{-output_was_subject}--;
231            $was = $self->{was_subject}->as_plain_string (%opt);
232          } elsif (length $self->{was_subject}) {
233            $was = $self->{was_subject};
234          }
235          $value = sprintf $option{format_was_subject}, $value, $was if defined $was;
236        }
237          my (%e) = &{$option{hook_encode_string}} ($self,
238            $value,
239            charset => $option{encoding_after_encode},
240            current_charset => $option{internal_charset},
241            type => 'text',
242          );
243          return $e{value};
244    }    }
   %e = &{$option{hook_encode_string}} ($self, $e{value}, type => 'text');  
   $e{value};  
245  }  }
246  *as_string = \&stringify;  *as_string = \&stringify;
247    
# Line 163  in internal code). Line 255  in internal code).
255    
256  sub as_plain_string ($;%) {  sub as_plain_string ($;%) {
257    my $self = shift;    my $self = shift;
258    $self->stringify (-hook_encode_string => sub {shift; (value => shift, @_)}, @_);    $self->stringify (
259  }      -hook_encode_string => sub { shift; (value => shift, @_) },
260        @_,
261  =item $text = $subject->text ([$new-text])    );
   
 Returns or set subject text (without prefixes such as "Re: ").  
   
 =item $text = $subject->value  
   
 An alias for C<text> method.  
   
 =cut  
   
 sub value ($$;$) {  
   my $self = shift;  
   my $ns = shift;  
   if (defined $ns) {  
     $self->{field_body} = $ns;  
   }  
   $self->{field_body};  
262  }  }
 *text = \&value;  
   
 =item $subject->change ($new-subject)  
263    
 Changes subject to new text.  Current subject is  
 moved to I<was: >, and current I<was: > subject, if any,  
 is removed.  
264    
 =cut  
   
 sub change ($$;%) {  
   my $self = shift;  
   my $new_string = shift;  
   my %option = @_;  $option{-no_was} = 1 unless defined $option{-no_was};  
   $self->{was} = $self->clone (%option);  
   $self->{field_body} = $new_string;  
   $self->{is_adv} = 0;  
   $self->{is_control} = 0;  
   $self->{is_foward} = 0;  
   $self->{is_reply} = 0;  
   $self;  
 }  
265    
266  =item $bool = $subject->is ($attribute [=> $bool])  =item $bool = $subject->is ($attribute [=> $bool])
267    
# Line 223  Example: Line 279  Example:
279  sub is ($@) {  sub is ($@) {
280    my $self = shift;    my $self = shift;
281    if (@_ == 1) {    if (@_ == 1) {
282      return $self->{ 'is_' . $_[0] };      my $query = shift;
283        if ($query eq 'advertisement') {
284          return $self->{value} =~ /$REG{prefix_advertisement}/x? 1:0;
285        } else {
286          return $self->{is}->{ $_[0] };
287        }
288    }    }
289    while (my ($name, $value) = splice (@_, 0, 2)) {    while (my ($name, $value) = splice (@_, 0, 2)) {
290      $self->{ 'is_' . $name } = $value;      $self->{is}->{ $name } = $value;
291    }    }
292  }  }
293    
294  =item $old_subject = $subject->was  =item $old_subject = $subject->was_subject
295    
296  Returns I<was: > subject.  Returns I<was: > subject.
297    
298  =cut  =cut
299    
300  sub was ($) {  sub was_subject ($) {
301    my $self = shift;    my $self = shift;
302    if (ref $self->{was}) {    $self->{was_subject} = $self->_parse_all (was => $self->{was_subject})
303      #      if $self->{option}->{parse_all};
304    } elsif ($self->{was}) {    $self->{was_subject};
305      $self->{was} = Message::Field::Subject->parse ($self->{was});  }
306      $self->{was}->{option} = {%{$self->{option}}};  
307    } else {  sub news_control ($) {
308      $self->{was} = new Message::Field::Subject;    my $self = shift;
309      $self->{was}->{option} = {%{$self->{option}}};    $self->{news_control} = $self->_parse_all (was => $self->{news_control})
310    }      if $self->{option}->{parse_all};
311    $self->{was};    $self->{news_control};
312  }  }
313    
314  =item $clone = $subject->clone ()  =item $clone = $subject->clone ()
# Line 256  Returns a copy of the object. Line 317  Returns a copy of the object.
317    
318  =cut  =cut
319    
320  sub clone ($;%) {  ## Inherited
   my $self = shift;  my %option = @_;  
   my $clone = $self->SUPER::clone;  
   for (grep {/^is_/} keys %{$self}) {  
     $clone->{$_} = $self->{$_};  
   }  
   if (!$option{-no_was} && $self->{was}) {  
     if (ref $self->{was}) {  
       $clone->{was} = $self->{was}->clone;  
     } else {  
       $clone->{was} = $self->{was};  
     }  
   }  
   $clone;  
 }  
   
 =head1 EXAMPLE  
   
   my $subject = parse Message::Field::Subject 'Re: cool message';  
   $subject->change (q{What's "cool"?});  
   print $subject;       # What's "cool"? (was: Re: cool message)  
321    
322  =head1 LICENSE  =head1 LICENSE
323    
Legend:
Removed from v.1.8  
changed lines
  Added in v.1.9
admin@suikawiki.org
 ViewVC Help
Powered by ViewVC 1.1.24