| 1 |
|
| 2 |
=head1 NAME |
| 3 |
|
| 4 |
Message::Field::Subject -- Perl module for Internet |
| 5 |
message header C<Subject:> field body |
| 6 |
|
| 7 |
=cut |
| 8 |
|
| 9 |
package Message::Field::Subject; |
| 10 |
use strict; |
| 11 |
use vars qw(%DEFAULT @ISA %REG $VERSION); |
| 12 |
$VERSION=do{my @r=(q$Revision: 1.12 $=~/\d+/g);sprintf "%d."."%02d" x $#r,@r}; |
| 13 |
require Message::Field::Structured; |
| 14 |
push @ISA, q(Message::Field::Structured); |
| 15 |
|
| 16 |
%REG = %Message::Util::REG; |
| 17 |
$REG{news_control} = qr/^cmsg$REG{WSP}+/; |
| 18 |
$REG{prefix_fwd} = qr/(?i)(?:Fwd?|Forward)/; |
| 19 |
$REG{prefix_list} = qr/[(\[][A-Za-z0-9._-]+[\x20:-]\d+[)\]]/; |
| 20 |
$REG{M_prefix_list} = qr/[(\[]([A-Za-z0-9._-]+)[\x20:-](\d+)[)\]]/; |
| 21 |
$REG{M_was_subject} = qr/\([Ww][Aa][Ss][:\x09\x20]$REG{FWS}(.+?)$REG{FWS}\)$REG{FWS}$/; |
| 22 |
$REG{message_from_subject} = qr/^$REG{FWS}(?i)Message from \S+$REG{FWS}$/; |
| 23 |
if ($^V gt v5.7.2) { |
| 24 |
$REG{prefix_re} = q/(?i)Re|Sv|Odp |
| 25 |
|\x{8FD4} ## Hen |
| 26 |
/; |
| 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{672B}] [\x09\x0A\x0D\x20\x{3000}]* |
| 34 |
\x{627F} [\x09\x0A\x0D\x20\x{3000}]* |
| 35 |
\x{8AFE} [\x09\x0A\x0D\x20\x{3000}]* |
| 36 |
\x{5E83} [\x09\x0A\x0D\x20\x{3000}]* |
| 37 |
[\x{543F}\x{544A}] [\x09\x0A\x0D\x20\x{3000}]* [\x{203B}\x{0FBF}] |
| 38 |
## mi shou daku kou koku * |
| 39 |
/x; |
| 40 |
} else { |
| 41 |
$REG{prefix_re} = qr/(?i)Re|Sv|Odp/; |
| 42 |
$REG{prefix_advertisement} = qr/(?i)ADV?:/; |
| 43 |
} |
| 44 |
$REG{prefix_general} = qr/((?:$REG{prefix_re}|$REG{prefix_fwd})\^?[\[\(]?\d*[\]\)]?[:>]$REG{FWS})+/x; |
| 45 |
$REG{prefix_general_list} = qr/($REG{prefix_general}|$REG{FWS}$REG{prefix_list}$REG{FWS})+/x; |
| 46 |
|
| 47 |
%DEFAULT = ( |
| 48 |
-_MEMBERS => [qw/is list_count list_name news_control was_subject/], |
| 49 |
-_METHODS => [qw/as_plain_string is list_count list_name |
| 50 |
news_control was_subject value value_type/], |
| 51 |
#encoding_after_encode |
| 52 |
#encoding_before_decode |
| 53 |
-format_news_control => 'cmsg %s', |
| 54 |
-format_prefix_fwd => 'Fwd: %s', |
| 55 |
-format_prefix_list => '[%s:%05d] %s', |
| 56 |
-format_prefix_re => 'Re: %s', |
| 57 |
-format_was_subject => '%s (was: %s)', |
| 58 |
#field_param_name |
| 59 |
#field_name |
| 60 |
#field_ns |
| 61 |
#format |
| 62 |
#header_default_charset |
| 63 |
#header_default_charset_input |
| 64 |
#hook_encode_string |
| 65 |
#hook_decode_string |
| 66 |
-output_general_prefix => 1, |
| 67 |
-output_list_prefix => 0, |
| 68 |
-output_news_control => 1, |
| 69 |
-output_was_subject => 1, ## ["-"] 1*DIGIT |
| 70 |
#parse_all |
| 71 |
-parse_was_subject => 1, |
| 72 |
-use_general_prefix => 1, |
| 73 |
-use_list_prefix => 1, |
| 74 |
-use_message_from_subject => 0, |
| 75 |
-use_news_control => 1, |
| 76 |
-use_was_subject => 1, |
| 77 |
#value_type |
| 78 |
); |
| 79 |
|
| 80 |
=head1 CONSTRUCTORS |
| 81 |
|
| 82 |
The following methods construct new objects: |
| 83 |
|
| 84 |
=over 4 |
| 85 |
|
| 86 |
=cut |
| 87 |
|
| 88 |
## Initialize of this class -- called by constructors |
| 89 |
sub _init ($;%) { |
| 90 |
my $self = shift; |
| 91 |
my %options = @_; |
| 92 |
$self->SUPER::_init (%DEFAULT, %options); |
| 93 |
|
| 94 |
my $fname = $self->{option}->{field_name}; |
| 95 |
if ($fname =~ /^x-.subject$/) { |
| 96 |
$self->{option}->{use_list_prefix} = 0 unless defined $options{-use_list_prefix}; |
| 97 |
$self->{option}->{use_news_control} = 0 unless defined $options{-use_news_control}; |
| 98 |
$self->{option}->{use_message_from_subject} = 0 unless defined $options{-use_message_from_subject}; |
| 99 |
} |
| 100 |
|
| 101 |
#$self->{option}->{value_type}->{news_control} = ['Message::Field::UsenetControl',{}, [qw//]]; |
| 102 |
$self->{option}->{value_type}->{was_subject} = ['Message::Field::Subject',{}, |
| 103 |
[qw/format_news_control format_prefix_fwd format_prefix_re |
| 104 |
format_was_subject output_general_prefix output_list_prefix |
| 105 |
output_news_control output_was_subject parse_was_subject |
| 106 |
use_general_prefix use_list_prefix use_news_control use_was_subject/]]; |
| 107 |
} |
| 108 |
|
| 109 |
=item $subject = Message::Field::Subject->new ([%options]) |
| 110 |
|
| 111 |
Constructs a new C<Message::Field::Subject> object. You might pass some |
| 112 |
options as parameters to the constructor. |
| 113 |
|
| 114 |
=cut |
| 115 |
|
| 116 |
## Inherited |
| 117 |
|
| 118 |
=item $subject = Message::Field::Subject->parse ($field-body, [%options]) |
| 119 |
|
| 120 |
Constructs a new C<Message::Field::Subject> object with |
| 121 |
given field body. You might pass some options as parameters to the constructor. |
| 122 |
|
| 123 |
=cut |
| 124 |
|
| 125 |
sub parse ($$;%) { |
| 126 |
my $class = shift; |
| 127 |
my $self = bless {}, $class; |
| 128 |
my $body = shift; |
| 129 |
$self->_init (@_); |
| 130 |
my $option = $self->{option}; |
| 131 |
if ($option->{use_news_control} && $body =~ s/$REG{news_control}//) { |
| 132 |
$self->{news_control} = $body; |
| 133 |
return $self; |
| 134 |
} |
| 135 |
my $value = ''; |
| 136 |
my %s = &{$self->{option}->{hook_decode_string}} ($self, |
| 137 |
$body, |
| 138 |
type => 'text', |
| 139 |
charset => $option->{encoding_before_decode}, |
| 140 |
); |
| 141 |
if ($s{charset}) { ## Convertion failed |
| 142 |
$self->{_charset} = $s{charset}; |
| 143 |
$self->{value} = $s{value}; |
| 144 |
return $self; |
| 145 |
} elsif (!$s{success}) { |
| 146 |
$self->{_charset} = $self->{option}->{header_default_charset_input}; |
| 147 |
$self->{value} = $s{value}; |
| 148 |
return $self; |
| 149 |
} |
| 150 |
$value = $s{value}; |
| 151 |
#if (!$option->{parse_all}) { |
| 152 |
# $self->{value} = $value; |
| 153 |
# return $self; |
| 154 |
#} |
| 155 |
if ($option->{use_general_prefix}) { |
| 156 |
if ($option->{use_list_prefix} && $value =~ s/^($REG{prefix_general_list})//x) { |
| 157 |
my $prefix = $1; |
| 158 |
$self->{is}->{reply} = 1 if $prefix =~ /$REG{prefix_re}/x; |
| 159 |
$self->{is}->{foward} = 1 if $prefix =~ /$REG{prefix_fwd}/x; |
| 160 |
($self->{list_name}, $self->{list_count}) = ($1, $2) |
| 161 |
if $prefix =~ /$REG{M_prefix_list}/x; |
| 162 |
} elsif ($value =~ s/^($REG{prefix_general})//x) { |
| 163 |
my $prefix = $1; |
| 164 |
$self->{is}->{reply} = 1 if $prefix =~ /$REG{prefix_re}/x; |
| 165 |
$self->{is}->{foward} = 1 if $prefix =~ /$REG{prefix_fwd}/x; |
| 166 |
} |
| 167 |
} elsif ($option->{use_list_prefix} && $value =~ s/^$REG{FWS}$REG{M_prefix_list}(?:$REG{FWS}$REG{prefix_list})*$REG{FWS}//x) { |
| 168 |
($self->{list_name}, $self->{list_count}) = ($1, $2); |
| 169 |
} |
| 170 |
if ($option->{use_was_subject} && $value =~ s/$REG{M_was_subject}//) { |
| 171 |
my $was = $1; |
| 172 |
if ($option->{parse_was_subject}) { |
| 173 |
my %option; |
| 174 |
for (keys %$option) { |
| 175 |
$option{ '-'.$_ } = Message::Util::make_clone ($option->{ $_ }); |
| 176 |
} |
| 177 |
$self->{was_subject} = ref ($self)->parse ($was, |
| 178 |
-hook_decode_string => sub { shift; (value => shift, @_) }, |
| 179 |
%option); |
| 180 |
} else { |
| 181 |
$self->{was_subject} = $was; |
| 182 |
} |
| 183 |
} |
| 184 |
if ($option->{use_message_from_subject} && $value =~ s/$REG{message_from_subject}//) { |
| 185 |
$self->{is}->{message_from_subject} = 1; |
| 186 |
} |
| 187 |
$self->{value} = $value; |
| 188 |
$self; |
| 189 |
} |
| 190 |
|
| 191 |
=back |
| 192 |
|
| 193 |
=head1 METHODS |
| 194 |
|
| 195 |
=over 4 |
| 196 |
|
| 197 |
=cut |
| 198 |
|
| 199 |
sub value ($;$) { |
| 200 |
my $self = shift; |
| 201 |
my $v = shift; |
| 202 |
if (defined $v) { |
| 203 |
$self->{value} = $v; |
| 204 |
} |
| 205 |
$self->{value}; |
| 206 |
} |
| 207 |
|
| 208 |
sub list_name ($) { $_[0]->{list_name} } |
| 209 |
sub list_count ($) { $_[0]->{list_count} } |
| 210 |
|
| 211 |
=item $body = $subject->stringify |
| 212 |
|
| 213 |
Retruns subject field body as string. String is encoded |
| 214 |
for message if necessary. |
| 215 |
|
| 216 |
=cut |
| 217 |
|
| 218 |
sub stringify ($;%) { |
| 219 |
my $self = shift; |
| 220 |
my %o = @_; my %option = %{$self->{option}}; |
| 221 |
for (grep {/^-/} keys %o) {$option{substr ($_, 1)} = $o{$_}} |
| 222 |
if ($option{use_news_control} && $option{output_news_control} |
| 223 |
&& $self->{news_control}) { |
| 224 |
my $c = $self->{news_control}; |
| 225 |
return '' unless length $c; |
| 226 |
return sprintf $option{format_news_control}, $c; |
| 227 |
} |
| 228 |
if ($self->{_charset}) { |
| 229 |
return $self->{value}; |
| 230 |
} else { |
| 231 |
my $value = $self->{value}; |
| 232 |
if ($option{use_general_prefix} && $option{output_general_prefix}) { |
| 233 |
$value = sprintf $option{format_prefix_re}, $value if $self->{is}->{reply}; |
| 234 |
$value = sprintf $option{format_prefix_fwd}, $value if $self->{is}->{foward}; |
| 235 |
} |
| 236 |
if ($option{use_list_prefix} && $option{output_list_prefix}) { |
| 237 |
$value = sprintf $option{format_prefix_list}, |
| 238 |
$self->{list_name}, $self->{list_count}, $value |
| 239 |
if length $self->{list_name} && defined $self->{list_count}; |
| 240 |
} |
| 241 |
if ($option{use_was_subject} && $option{output_was_subject} > 0) { |
| 242 |
my $was; |
| 243 |
if (ref $self->{was_subject}) { |
| 244 |
my %opt = @_; |
| 245 |
$opt{-output_was_subject} = $opt{output_was_subject} |
| 246 |
unless defined $opt{-output_was_subject}; |
| 247 |
$opt{-output_was_subject}--; |
| 248 |
$was = $self->{was_subject}->as_plain_string (%opt); |
| 249 |
} elsif (length $self->{was_subject}) { |
| 250 |
$was = $self->{was_subject}; |
| 251 |
} |
| 252 |
$value = sprintf $option{format_was_subject}, $value, $was if defined $was; |
| 253 |
} |
| 254 |
my (%e) = &{$option{hook_encode_string}} ($self, |
| 255 |
$value, |
| 256 |
charset => $option{encoding_after_encode}, |
| 257 |
current_charset => $option{internal_charset}, |
| 258 |
type => 'text', |
| 259 |
); |
| 260 |
return $e{value}; |
| 261 |
} |
| 262 |
} |
| 263 |
*as_string = \&stringify; |
| 264 |
|
| 265 |
=item $body = $subject->as_plain_string |
| 266 |
|
| 267 |
Returns subject field body as string. Unlike C<stringify>, |
| 268 |
retrun string of this method is not encoded (i.e. returned |
| 269 |
in internal code). |
| 270 |
|
| 271 |
=cut |
| 272 |
|
| 273 |
sub as_plain_string ($;%) { |
| 274 |
my $self = shift; |
| 275 |
$self->stringify ( |
| 276 |
-hook_encode_string => sub { shift; (value => shift, @_) }, |
| 277 |
@_, |
| 278 |
); |
| 279 |
} |
| 280 |
|
| 281 |
|
| 282 |
|
| 283 |
=item $bool = $subject->is ($attribute [=> $bool]) |
| 284 |
|
| 285 |
Set/gets attribute value. |
| 286 |
|
| 287 |
Example: |
| 288 |
|
| 289 |
$isreply = $subject->is ('re'); |
| 290 |
## Strictly, this checks whether start with "Re: " or not. |
| 291 |
|
| 292 |
$subject->is (foward => 1, re => 0); |
| 293 |
|
| 294 |
=cut |
| 295 |
|
| 296 |
sub is ($@) { |
| 297 |
my $self = shift; |
| 298 |
if (@_ == 1) { |
| 299 |
my $query = shift; |
| 300 |
if ($query eq 'advertisement') { |
| 301 |
return $self->{value} =~ /$REG{prefix_advertisement}/x? 1:0; |
| 302 |
} else { |
| 303 |
return $self->{is}->{ $_[0] }; |
| 304 |
} |
| 305 |
} |
| 306 |
while (my ($name, $value) = splice (@_, 0, 2)) { |
| 307 |
$self->{is}->{ $name } = $value; |
| 308 |
} |
| 309 |
} |
| 310 |
|
| 311 |
=item $old_subject = $subject->was_subject |
| 312 |
|
| 313 |
Returns I<was: > subject. |
| 314 |
|
| 315 |
=cut |
| 316 |
|
| 317 |
sub was_subject ($) { |
| 318 |
my $self = shift; |
| 319 |
$self->{was_subject} = $self->_parse_all (was => $self->{was_subject}) |
| 320 |
if $self->{option}->{parse_all}; |
| 321 |
$self->{was_subject}; |
| 322 |
} |
| 323 |
|
| 324 |
sub news_control ($) { |
| 325 |
my $self = shift; |
| 326 |
$self->{news_control} = $self->_parse_all (was => $self->{news_control}) |
| 327 |
if $self->{option}->{parse_all}; |
| 328 |
$self->{news_control}; |
| 329 |
} |
| 330 |
|
| 331 |
=item $clone = $subject->clone () |
| 332 |
|
| 333 |
Returns a copy of the object. |
| 334 |
|
| 335 |
=cut |
| 336 |
|
| 337 |
## Inherited |
| 338 |
|
| 339 |
=head1 LICENSE |
| 340 |
|
| 341 |
Copyright 2002 wakaba E<lt>w@suika.fam.cxE<gt>. |
| 342 |
|
| 343 |
This program is free software; you can redistribute it and/or modify |
| 344 |
it under the terms of the GNU General Public License as published by |
| 345 |
the Free Software Foundation; either version 2 of the License, or |
| 346 |
(at your option) any later version. |
| 347 |
|
| 348 |
This program is distributed in the hope that it will be useful, |
| 349 |
but WITHOUT ANY WARRANTY; without even the implied warranty of |
| 350 |
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the |
| 351 |
GNU General Public License for more details. |
| 352 |
|
| 353 |
You should have received a copy of the GNU General Public License |
| 354 |
along with this program; see the file COPYING. If not, write to |
| 355 |
the Free Software Foundation, Inc., 59 Temple Place - Suite 330, |
| 356 |
Boston, MA 02111-1307, USA. |
| 357 |
|
| 358 |
=head1 CHANGE |
| 359 |
|
| 360 |
See F<ChangeLog>. |
| 361 |
$Date: 2002/11/13 08:08:52 $ |
| 362 |
|
| 363 |
=cut |
| 364 |
|
| 365 |
1; |
Parent Directory
| 
Revision Log