/[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.4 by wakaba, Sun Mar 31 13:11:55 2002 UTC revision 1.5 by wakaba, Sat Apr 13 01:33:54 2002 UTC
# Line 1  Line 1 
1    
2  =head1 NAME  =head1 NAME
3    
4  Message::Field::Subject Perl module  Message::Field::Subject -- Perl module for Internet
5    message header C<Subject:> field body
 =head1 DESCRIPTION  
   
 Perl module for RFC 822/2822 C<Subject> C<field>.  
6    
7  =cut  =cut
8    
9  package Message::Field::Subject;  package Message::Field::Subject;
 require 5.6.0;  
10  use strict;  use strict;
11  use re 'eval';  use vars qw(@ISA %REG $VERSION);
 use vars qw(%DEFAULT %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::Util;
14    require Message::Field::Unstructured;
15    push @ISA, q(Message::Field::Unstructured);
16  use overload '""' => sub {shift->stringify};  use overload '""' => sub {shift->stringify};
17  $REG{FWS} = qr/[\x09\x20]*/;  
18    *REG = \%Message::Util::REG;
19  $REG{re} = qr/(?:[Rr][Ee]|[Ss][Vv])\^?\[?[0-9]*\]?:/;  $REG{re} = qr/(?:[Rr][Ee]|[Ss][Vv])\^?\[?[0-9]*\]?:/;
20  $REG{fwd} = qr/[Ff][Ww][Dd]?:/;  $REG{fwd} = qr/[Ff][Ww][Dd]?:/;
21  $REG{ml} = qr/[(\[][A-Za-z0-9._-]+[\x20:-][0-9]+[)\]]/;  $REG{ml} = qr/[(\[][A-Za-z0-9._-]+[\x20:-][0-9]+[)\]]/;
# Line 27  $REG{prefix} = qr/(?:$REG{re}|$REG{fwd}| Line 24  $REG{prefix} = qr/(?:$REG{re}|$REG{fwd}|
24  $REG{M_control} = qr/^cmsg$REG{FWS}([\x00-\xFF]*)$/;  $REG{M_control} = qr/^cmsg$REG{FWS}([\x00-\xFF]*)$/;
25  $REG{M_was} = qr/\([Ww][Aa][Ss]:? ([\x00-\xFF]+)\)$REG{FWS}$/;  $REG{M_was} = qr/\([Ww][Aa][Ss]:? ([\x00-\xFF]+)\)$REG{FWS}$/;
26    
27  %DEFAULT = (  =head1 CONSTRUCTORS
   encoding_after_encode => '*default',  
   encoding_before_decode        => '*default',  
   hook_encode_string    => #sub {shift; (value => shift, @_)},  
         \&Message::Util::encode_header_string,  
   hook_decode_string    => #sub {shift; (value => shift, @_)},  
         \&Message::Util::decode_header_string,  
   string_re     => 'Re: ',  
   string_was    => ' (was: %s)',  
 );  
28    
29  =head2 Message::Field::Subject->new ()  The following methods construct new C<Message::Field::Subject> objects:
30    
31  Returns empty subject object.  =over 4
32    
33  =cut  =cut
34    
35  sub new ($;%) {  ## Initialize of this class -- called by constructors
36    my $class = shift;  sub _init ($;%) {
37    my $self = bless {option => {@_}}, $class;    my $self = shift;
38    for (keys %DEFAULT) {$self->{option}->{$_} ||= $DEFAULT{$_}}    my %options = @_;
39    $self;    my %DEFAULT = (
40        #encoding_after_encode      ## Inherited
41        #encoding_before_decode     ## Inherited
42        -format_adv => 'ADV: %s',
43        -format_fwd => 'Fwd: %s',
44        -format_re  => 'Re: %s',
45        -format_was => '%s (was: %s)',
46        #hook_encode_string ## Inherited
47        #hook_decode_string ## Inherited
48        -prefix_cmsg        => 'cmsg ',
49        -regex_adv  => qr/(?i)ADV:/,
50        -regex_adv_check    => qr/^ADV:/,
51        -remove_ml_prefix   => 1,
52      );
53      $self->SUPER::_init (%DEFAULT, %options);
54      
55      unless ($self->{option}->{remove_ml_prefix}) {
56        $REG{prefix} = qr/(?:$REG{re}|$REG{fwd})(?:$REG{FWS}(?:$REG{re}|$REG{fwd}))*/;
57      }
58  }  }
59    
60  =head2 Message::Field::Subject->parse ($unfolded_field_body)  =item $subject = Message::Field::Subject->new ([%options])
61    
62  Parses subject C<field-body>.  Even C<Subject> is unstructured  Constructs a new C<Message::Field::Subject> object.  You might pass some
63  field body, "Re: " prefix or mail-list name and number  options as parameters to the constructor.
64  are widely used.  
65    =cut
66    
67    ## Inherited
68    
69    =item $subject = Message::Field::Subject->parse ($field-body, [%options])
70    
71    Constructs a new C<Message::Field::Subject> object with
72    given field body.  You might pass some options as parameters to the constructor.
73    
74  =cut  =cut
75    
76  sub parse ($$;%) {  sub parse ($$;%) {
77    my $class = shift;    my $class = shift;
78      my $self = bless {}, $class;
79    my $field_body = shift;    my $field_body = shift;
80    my $self = bless {option => {@_}}, $class;    $self->_init (@_);
   for (keys %DEFAULT) {$self->{option}->{$_} ||= $DEFAULT{$_}}  
81    if ($field_body =~ /$REG{M_control}/) {    if ($field_body =~ /$REG{M_control}/) {
82      $self->{control} = $1;      $self->{is_control} = 1;    ## Obsoleted control message
83        $self->{field_body} = $1;   ## TODO: passes to Message::Field::Control
84      return $self;      return $self;
85    }    }
86    my %s = &{$self->{option}->{hook_decode_string}} ($self, $field_body,    my %s = &{$self->{option}->{hook_decode_string}} ($self, $field_body,
87              type => 'text');      type => 'text');  $field_body = $s{value};
   $field_body = $s{value};  
88    $field_body =~ s{^$REG{FWS}($REG{prefix})$REG{FWS}}{    $field_body =~ s{^$REG{FWS}($REG{prefix})$REG{FWS}}{
89      my $prefix = $1;      my $prefix = $1;
90      $self->{is_reply} = 1 if $prefix =~ /$REG{re}/;      $self->{is_reply} = 1 if $prefix =~ /$REG{re}/;
# Line 80  sub parse ($$;%) { Line 94  sub parse ($$;%) {
94      }      }
95      ''      ''
96    }ex;    }ex;
97      $self->{is_adv} = 1 if $field_body =~ /$self->{option}->{regex_adv}/;
98    $field_body =~ s{$REG{FWS}$REG{M_was}}{    $field_body =~ s{$REG{FWS}$REG{M_was}}{
99      $self->{was} = Message::Field::Subject->parse ($1);      my $was = $1;
100        if ($self->{option}->{parse_was}) {
101          $self->{was} = Message::Field::Subject->parse ($was);
102          $self->{was}->{option} = {%{$self->{option}}};
103            ## WARNING: this does not support the cases that some of option
104            ## values are reference to something.
105        } else {
106          $self->{was} = $was;
107        }
108      ''      ''
109    }ex;    }ex;
110    $self->{field_body} = $field_body;    $self->{field_body} = $field_body;
111    $self;    $self;
112  }  }
113    
114    =back
115    
116    =head1 METHODS
117    
118    =over 4
119    
120    =item $body = $subject->stringify
121    
122    Retruns subject field body as string.  String is encoded
123    for message if necessary.
124    
125    =cut
126    
127  sub stringify ($;%) {  sub stringify ($;%) {
128    my $self = shift;    my $self = shift;  my %o = @_;
129    my %option = @_;    my %option = %{$self->{option}};
130    $option{string_re} ||= $self->{option}->{string_re};    for (grep {/^-/} keys %o) {$option{substr ($_, 1)} = $o{$_}}
131    $option{string_was} ||= $self->{option}->{string_was};    if ($self->{is_control}) {
132    my (%e) = &{$self->{option}->{hook_encode_string}} ($self,      my $s = $self->{field_body};
133            $self->{field_body}, type => 'text');      $s = $option{prefix_cmsg}.$s if $s;
134    ($self->{is_reply}>0? $option{string_re}: '').$e{value}      return $s;
135    .(length $self->{was}? sprintf ($option{string_was}, $self->{was}): '');    }
136      my %e = (value => $self->{field_body});
137      my $was = (ref $self->{was}? $self->{was}->as_plain_string: $self->{was});
138      if ($self->{is_reply}) {
139        $e{value} = sprintf $option{format_re}, $e{value};
140      }
141      if ($self->{is_foward}) {
142        $e{value} = sprintf $option{format_fwd}, $e{value};
143      }
144      if (length $was) {
145        $e{value} = sprintf $option{format_was}, $e{value} => $was;
146      }
147      if ($self->{is_adv}
148       && $self->{field_body} !~ /$option{regex_adv_check}/) {
149        $e{value} = sprintf $option{format_adv}, $e{value};
150      }
151      %e = &{$option{hook_encode_string}} ($self, $e{value}, type => 'text');
152      $e{value};
153  }  }
154  sub as_string ($;%) {shift->stringify (@_)}  *as_string = \&stringify;
155    
156    =item $body = $subject->as_plain_string
157    
158    Returns subject field body as string.  Unlike C<stringify>,
159    retrun string of this method is not encoded (i.e. returned
160    in internal code).
161    
162    =cut
163    
164  sub as_plain_string ($;%) {  sub as_plain_string ($;%) {
165    my $self = shift;    my $self = shift;
166    my %option = @_;    $self->stringify (-hook_encode_string => sub {shift; (value => shift, @_)}, @_);
   $option{string_re} ||= $self->{option}->{string_re};  
   $option{string_was} ||= $self->{option}->{string_was};  
   ($self->{is_reply}>0? $option{string_re}: '').$self->{field_body}  
   .(length $self->{was}?  
     sprintf ($option{string_was}, $self->{was}->as_plain_string): '');  
167  }  }
168    
169  sub is ($$;$) {  =item $text = $subject->text ([$new-text])
170    
171    Returns or set subject text (without prefixes such as "Re: ").
172    
173    =item $text = $subject->value
174    
175    An alias for C<text> method.
176    
177    =cut
178    
179    ## value: Inherited
180    *text = \&value;
181    
182    =item $subject->change ($new-subject)
183    
184    Changes subject to new text.  Current subject is
185    moved to I<was: >, and current I<was: > subject, if any,
186    is removed.
187    
188    =cut
189    
190    sub change ($$;%) {
191    my $self = shift;    my $self = shift;
192    my $valname = shift;    my $new_string = shift;
193    my $newval = shift;    my %option = @_;  $option{-no_was} = 1 unless defined $option{-no_was};
194    if (defined $newval) {    $self->{was} = $self->clone (%option);
195      $self->{'is_'.$valname} = $newval;    $self->{field_body} = $new_string;
196    }    $self->{is_adv} = 0;
197    $self->{'is_'.$valname};    $self->{is_control} = 0;
198      $self->{is_foward} = 0;
199      $self->{is_reply} = 0;
200      $self;
201  }  }
202    
203  sub option ($$;$) {  =item $bool = $subject->is ($attribute [=> $bool])
204    
205    Set/gets attribute value.
206    
207    Example:
208    
209      $isreply = $subject->is ('re');
210            ## Strictly, this checks whether start with "Re: " or not.
211    
212      $subject->is (foward => 1, re => 0);
213    
214    =cut
215    
216    sub is ($@) {
217    my $self = shift;    my $self = shift;
218    my $valname = shift;    if (@_ == 1) {
219    my $newval = shift;      return $self->{ 'is_' . $_[0] };
220    if (defined $newval) {    }
221      $self->{option}->{$valname} = $newval;    while (my ($name, $value) = splice (@_, 0, 2)) {
222        $self->{ 'is_' . $name } = $value;
223    }    }
   $self->{option}->{$valname};  
224  }  }
225    
226    =item $old_subject = $subject->was
227    
228    Returns I<was: > subject.
229    
230    =cut
231    
232  sub was ($) {  sub was ($) {
233    my $self = shift;    my $self = shift;
234    if (ref $self->{was}) {    if (ref $self->{was}) {
235      #      #
236    } elsif ($self->{was}) {    } elsif ($self->{was}) {
237      $self->{was} = Message::Field::Subject->parse ($self->{was});      $self->{was} = Message::Field::Subject->parse ($self->{was});
238        $self->{was}->{option} = {%{$self->{option}}};
239    } else {    } else {
240      $self->{was} = new Message::Field::Subject;      $self->{was} = new Message::Field::Subject;
241        $self->{was}->{option} = {%{$self->{option}}};
242    }    }
243    $self->{was};    $self->{was};
244  }  }
245    
246  sub set ($$) {  =item $clone = $subject->clone ()
   my $self = shift;  
   my $new_string = shift;  
   $self->{field_body} = $new_string;  
   $self;  
 }  
247    
248  sub set_new ($$) {  Returns a copy of the object.
249    my $self = shift;  
250    my $new_string = shift;  =cut
251    $self->was->{field_body} = $self->{field_body};  
252    $self->{was}->{is_reply} = $self->{is_reply};  sub clone ($;%) {
253    $self->{was}->{option}   = {%{$self->{option}}};    my $self = shift;  my %option = @_;
254    $self->{field_body} = $new_string;    my $clone = $self->SUPER::clone;
255    $self->{is_reply} = -1;    for (grep {/^is_/} keys %{$self}) {
256    $self;      $clone->{$_} = $self->{$_};
257      }
258      if (!$option{-no_was} && $self->{was}) {
259        if (ref $self->{was}) {
260          $clone->{was} = $self->{was}->clone;
261        } else {
262          $clone->{was} = $self->{was};
263        }
264      }
265      $clone;
266  }  }
267    
268    =head1 EXAMPLE
269    
270      my $subject = parse Message::Field::Subject 'Re: cool message';
271      $subject->change (q{What's "cool"?});
272      print $subject;       # What's "cool"? (was: Re: cool message)
273    
274  =head1 LICENSE  =head1 LICENSE
275    
276  Copyright 2002 wakaba E<lt>w@suika.fam.cxE<gt>.  Copyright 2002 wakaba E<lt>w@suika.fam.cxE<gt>.
# Line 182  Boston, MA 02111-1307, USA. Line 293  Boston, MA 02111-1307, USA.
293  =head1 CHANGE  =head1 CHANGE
294    
295  See F<ChangeLog>.  See F<ChangeLog>.
296    $Date$
297    
298  =cut  =cut
299    
Legend:
Removed from v.1.4  
changed lines
  Added in v.1.5
admin@suikawiki.org
 ViewVC Help
Powered by ViewVC 1.1.24