Message/Field/Subject.pm


=head1 NAME

Message::Field::Subject -- Perl module for Internet
message header C<Subject:> field body

=cut

package Message::Field::Subject;
use strict;
use vars qw(@ISA %REG $VERSION);
$VERSION=do{my @r=(q$Revision: 1.4 $=~/\d+/g);sprintf "%d."."%02d" x $#r,@r};
require Message::Util;
require Message::Field::Unstructured;
push @ISA, q(Message::Field::Unstructured);
use overload '""' => sub {shift->stringify};

*REG = \%Message::Util::REG;
$REG{re} = qr/(?:[Rr][Ee]|[Ss][Vv])\^?\[?[0-9]*\]?:/;
$REG{fwd} = qr/[Ff][Ww][Dd]?:/;
$REG{ml} = qr/[(\[][A-Za-z0-9._-]+[\x20:-][0-9]+[)\]]/;
$REG{M_ml} = qr/[(\[]([A-Za-z0-9._-]+)[\x20:-]([0-9]+)[)\]]/;
$REG{prefix} = qr/(?:$REG{re}|$REG{fwd}|$REG{ml})(?:$REG{FWS}(?:$REG{re}|$REG{fwd}|$REG{ml}))*/;
$REG{M_control} = qr/^cmsg$REG{FWS}([\x00-\xFF]*)$/;
$REG{M_was} = qr/\([Ww][Aa][Ss]:? ([\x00-\xFF]+)\)$REG{FWS}$/;

=head1 CONSTRUCTORS

The following methods construct new C<Message::Field::Subject> objects:

=over 4

=cut

## Initialize of this class -- called by constructors
sub _init ($;%) {
  my $self = shift;
  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,
  );
  $self->SUPER::_init (%DEFAULT, %options);
  
  unless ($self->{option}->{remove_ml_prefix}) {
    $REG{prefix} = qr/(?:$REG{re}|$REG{fwd})(?:$REG{FWS}(?:$REG{re}|$REG{fwd}))*/;
  }
}

=item $subject = Message::Field::Subject->new ([%options])

Constructs a new C<Message::Field::Subject> object.  You might pass some 
options as parameters to the constructor.

=cut

## Inherited

=item $subject = Message::Field::Subject->parse ($field-body, [%options])

Constructs a new C<Message::Field::Subject> object with
given field body.  You might pass some options as parameters to the constructor.

=cut

sub parse ($$;%) {
  my $class = shift;
  my $self = bless {}, $class;
  my $field_body = shift;
  $self->_init (@_);
  if ($field_body =~ /$REG{M_control}/) {
    $self->{is_control} = 1;    ## Obsoleted control message
    $self->{field_body} = $1;   ## TODO: passes to Message::Field::Control
    return $self;
  }
  my %s = &{$self->{option}->{hook_decode_string}} ($self, $field_body,
    type => 'text');  $field_body = $s{value};
  $field_body =~ s{^$REG{FWS}($REG{prefix})$REG{FWS}}{
    my $prefix = $1;
    $self->{is_reply} = 1 if $prefix =~ /$REG{re}/;
    $self->{is_foward} = 1 if $prefix =~ /$REG{fwd}/;
    if ($prefix =~ /$REG{M_ml}/) {
      ($self->{ml_name}, $self->{ml_count}) = ($1, $2);
    }
    ''
  }ex;
  $self->{is_adv} = 1 if $field_body =~ /$self->{option}->{regex_adv}/;
  $field_body =~ s{$REG{FWS}$REG{M_was}}{
    my $was = $1;
    if ($self->{option}->{parse_was}) {
      $self->{was} = Message::Field::Subject->parse ($was);
      $self->{was}->{option} = {%{$self->{option}}};
        ## WARNING: this does not support the cases that some of option
        ## values are reference to something.
    } else {
      $self->{was} = $was;
    }
    ''
  }ex;
  $self->{field_body} = $field_body;
  $self;
}

=back

=head1 METHODS

=over 4

=item $body = $subject->stringify

Retruns subject field body as string.  String is encoded
for message if necessary.

=cut

sub stringify ($;%) {
  my $self = shift;  my %o = @_;
  my %option = %{$self->{option}};
  for (grep {/^-/} keys %o) {$option{substr ($_, 1)} = $o{$_}}
  if ($self->{is_control}) {
    my $s = $self->{field_body};
    $s = $option{prefix_cmsg}.$s if $s;
    return $s;
  }
  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};
  }
  if ($self->{is_foward}) {
    $e{value} = sprintf $option{format_fwd}, $e{value};
  }
  if (length $was) {
    $e{value} = sprintf $option{format_was}, $e{value} => $was;
  }
  if ($self->{is_adv}
   && $self->{field_body} !~ /$option{regex_adv_check}/) {
    $e{value} = sprintf $option{format_adv}, $e{value};
  }
  %e = &{$option{hook_encode_string}} ($self, $e{value}, type => 'text');
  $e{value};
}
*as_string = \&stringify;

=item $body = $subject->as_plain_string

Returns subject field body as string.  Unlike C<stringify>,
retrun string of this method is not encoded (i.e. returned
in internal code).

=cut

sub as_plain_string ($;%) {
  my $self = shift;
  $self->stringify (-hook_encode_string => sub {shift; (value => shift, @_)}, @_);
}

=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

## value: Inherited
*text = \&value;

=item $subject->change ($new-subject)

Changes subject to new text.  Current subject is
moved to I<was: >, and current I<was: > subject, if any,
is removed.

=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;
}

=item $bool = $subject->is ($attribute [=> $bool])

Set/gets attribute value.

Example:

  $isreply = $subject->is ('re');
        ## Strictly, this checks whether start with "Re: " or not.

  $subject->is (foward => 1, re => 0);

=cut

sub is ($@) {
  my $self = shift;
  if (@_ == 1) {
    return $self->{ 'is_' . $_[0] };
  }
  while (my ($name, $value) = splice (@_, 0, 2)) {
    $self->{ 'is_' . $name } = $value;
  }
}

=item $old_subject = $subject->was

Returns I<was: > subject.

=cut

sub was ($) {
  my $self = shift;
  if (ref $self->{was}) {
    #
  } elsif ($self->{was}) {
    $self->{was} = Message::Field::Subject->parse ($self->{was});
    $self->{was}->{option} = {%{$self->{option}}};
  } else {
    $self->{was} = new Message::Field::Subject;
    $self->{was}->{option} = {%{$self->{option}}};
  }
  $self->{was};
}

=item $clone = $subject->clone ()

Returns a copy of the object.

=cut

sub clone ($;%) {
  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)

=head1 LICENSE

Copyright 2002 wakaba E<lt>w@suika.fam.cxE<gt>.

This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2 of the License, or
(at your option) any later version.

This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
GNU General Public License for more details.

You should have received a copy of the GNU General Public License
along with this program; see the file COPYING.  If not, write to
the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
Boston, MA 02111-1307, USA.

=head1 CHANGE

See F<ChangeLog>.
$Date: $

=cut

1;
1	wakaba	1.1
2			=head1 NAME
3
4	wakaba	1.5	Message::Field::Subject -- Perl module for Internet
5			message header C<Subject:> field body
6	wakaba	1.1
7			=cut
8
9			package Message::Field::Subject;
10			use strict;
11	wakaba	1.5	use vars qw(@ISA %REG $VERSION);
12			$VERSION=do{my @r=(q$Revision: 1.4 $=~/\d+/g);sprintf "%d."."%02d" x $#r,@r};
13	wakaba	1.3	require Message::Util;
14	wakaba	1.5	require Message::Field::Unstructured;
15			push @ISA, q(Message::Field::Unstructured);
16			use overload '""' => sub {shift->stringify};
17	wakaba	1.1
18	wakaba	1.5	*REG = \%Message::Util::REG;
19	wakaba	1.2	$REG{re} = qr/(?:[Rr][Ee]\|[Ss][Vv])\^?\[?[0-9]*\]?:/;
20	wakaba	1.1	$REG{fwd} = qr/[Ff][Ww][Dd]?:/;
21			$REG{ml} = qr/[(\[][A-Za-z0-9._-]+[\x20:-][0-9]+[)\]]/;
22			$REG{M_ml} = qr/[(\[]([A-Za-z0-9._-]+)[\x20:-]([0-9]+)[)\]]/;
23			$REG{prefix} = qr/(?:$REG{re}\|$REG{fwd}\|$REG{ml})(?:$REG{FWS}(?:$REG{re}\|$REG{fwd}\|$REG{ml}))*/;
24			$REG{M_control} = qr/^cmsg$REG{FWS}([\x00-\xFF]*)$/;
25			$REG{M_was} = qr/\([Ww][Aa][Ss]:? ([\x00-\xFF]+)\)$REG{FWS}$/;
26
27	wakaba	1.5	=head1 CONSTRUCTORS
28	wakaba	1.1
29	wakaba	1.5	The following methods construct new C<Message::Field::Subject> objects:
30	wakaba	1.1
31	wakaba	1.5	=over 4
32	wakaba	1.1
33			=cut
34
35	wakaba	1.5	## Initialize of this class -- called by constructors
36			sub _init ($;%) {
37			my $self = shift;
38			my %options = @_;
39			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	wakaba	1.1	}
59
60	wakaba	1.5	=item $subject = Message::Field::Subject->new ([%options])
61	wakaba	1.1
62	wakaba	1.5	Constructs a new C<Message::Field::Subject> object. You might pass some
63			options as parameters to the constructor.
64
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	wakaba	1.1
74			=cut
75
76			sub parse ($$;%) {
77			my $class = shift;
78	wakaba	1.5	my $self = bless {}, $class;
79	wakaba	1.1	my $field_body = shift;
80	wakaba	1.5	$self->_init (@_);
81	wakaba	1.1	if ($field_body =~ /$REG{M_control}/) {
82	wakaba	1.5	$self->{is_control} = 1; ## Obsoleted control message
83			$self->{field_body} = $1; ## TODO: passes to Message::Field::Control
84	wakaba	1.1	return $self;
85			}
86	wakaba	1.3	my %s = &{$self->{option}->{hook_decode_string}} ($self, $field_body,
87	wakaba	1.5	type => 'text'); $field_body = $s{value};
88	wakaba	1.1	$field_body =~ s{^$REG{FWS}($REG{prefix})$REG{FWS}}{
89			my $prefix = $1;
90			$self->{is_reply} = 1 if $prefix =~ /$REG{re}/;
91			$self->{is_foward} = 1 if $prefix =~ /$REG{fwd}/;
92			if ($prefix =~ /$REG{M_ml}/) {
93			($self->{ml_name}, $self->{ml_count}) = ($1, $2);
94			}
95			''
96			}ex;
97	wakaba	1.5	$self->{is_adv} = 1 if $field_body =~ /$self->{option}->{regex_adv}/;
98	wakaba	1.1	$field_body =~ s{$REG{FWS}$REG{M_was}}{
99	wakaba	1.5	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	wakaba	1.1	''
109			}ex;
110			$self->{field_body} = $field_body;
111			$self;
112			}
113
114	wakaba	1.5	=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	wakaba	1.1	sub stringify ($;%) {
128	wakaba	1.5	my $self = shift; my %o = @_;
129			my %option = %{$self->{option}};
130			for (grep {/^-/} keys %o) {$option{substr ($_, 1)} = $o{$_}}
131			if ($self->{is_control}) {
132			my $s = $self->{field_body};
133			$s = $option{prefix_cmsg}.$s if $s;
134			return $s;
135			}
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	wakaba	1.1	}
154	wakaba	1.5	*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	wakaba	1.1
164	wakaba	1.3	sub as_plain_string ($;%) {
165	wakaba	1.1	my $self = shift;
166	wakaba	1.5	$self->stringify (-hook_encode_string => sub {shift; (value => shift, @_)}, @_);
167	wakaba	1.1	}
168
169	wakaba	1.5	=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	wakaba	1.1	my $self = shift;
192	wakaba	1.5	my $new_string = shift;
193			my %option = @_; $option{-no_was} = 1 unless defined $option{-no_was};
194			$self->{was} = $self->clone (%option);
195			$self->{field_body} = $new_string;
196			$self->{is_adv} = 0;
197			$self->{is_control} = 0;
198			$self->{is_foward} = 0;
199			$self->{is_reply} = 0;
200			$self;
201	wakaba	1.1	}
202
203	wakaba	1.5	=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	wakaba	1.1	my $self = shift;
218	wakaba	1.5	if (@_ == 1) {
219			return $self->{ 'is_' . $_[0] };
220			}
221			while (my ($name, $value) = splice (@_, 0, 2)) {
222			$self->{ 'is_' . $name } = $value;
223	wakaba	1.1	}
224			}
225
226	wakaba	1.5	=item $old_subject = $subject->was
227
228			Returns I<was: > subject.
229
230			=cut
231
232	wakaba	1.1	sub was ($) {
233			my $self = shift;
234			if (ref $self->{was}) {
235			#
236			} elsif ($self->{was}) {
237			$self->{was} = Message::Field::Subject->parse ($self->{was});
238	wakaba	1.5	$self->{was}->{option} = {%{$self->{option}}};
239	wakaba	1.1	} else {
240			$self->{was} = new Message::Field::Subject;
241	wakaba	1.5	$self->{was}->{option} = {%{$self->{option}}};
242	wakaba	1.1	}
243			$self->{was};
244			}
245
246	wakaba	1.5	=item $clone = $subject->clone ()
247
248			Returns a copy of the object.
249
250			=cut
251
252			sub clone ($;%) {
253			my $self = shift; my %option = @_;
254			my $clone = $self->SUPER::clone;
255			for (grep {/^is_/} keys %{$self}) {
256			$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	wakaba	1.1	}
267
268	wakaba	1.5	=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	wakaba	1.1
274			=head1 LICENSE
275
276			Copyright 2002 wakaba E<lt>w@suika.fam.cxE<gt>.
277
278			This program is free software; you can redistribute it and/or modify
279			it under the terms of the GNU General Public License as published by
280			the Free Software Foundation; either version 2 of the License, or
281			(at your option) any later version.
282
283			This program is distributed in the hope that it will be useful,
284			but WITHOUT ANY WARRANTY; without even the implied warranty of
285			MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
286			GNU General Public License for more details.
287
288			You should have received a copy of the GNU General Public License
289			along with this program; see the file COPYING. If not, write to
290			the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
291			Boston, MA 02111-1307, USA.
292
293			=head1 CHANGE
294
295			See F<ChangeLog>.
296	wakaba	1.5	$Date: $
297	wakaba	1.1
298			=cut
299
300			1;