Message/Field/Subject.pm


=head1 NAME

Message::Field::Subject Perl module

=head1 DESCRIPTION

Perl module for RFC 822/2822 C<Subject> C<field>.

=cut

package Message::Field::Subject;
require 5.6.0;
use strict;
use re 'eval';
use vars qw(%DEFAULT %REG $VERSION);
$VERSION=do{my @r=(q$Revision: 1.3 $=~/\d+/g);sprintf "%d."."%02d" x $#r,@r};
require Message::Util;

use overload '""' => sub {shift->stringify};
$REG{FWS} = qr/[\x09\x20]*/;
$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}$/;

%DEFAULT = (
  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)',
);

=head2 Message::Field::Subject->new ()

Returns empty subject object.

=cut

sub new ($;%) {
  my $class = shift;
  my $self = bless {option => {@_}}, $class;
  for (keys %DEFAULT) {$self->{option}->{$_} ||= $DEFAULT{$_}}
  $self;
}

=head2 Message::Field::Subject->parse ($unfolded_field_body)

Parses subject C<field-body>.  Even C<Subject> is unstructured
field body, "Re: " prefix or mail-list name and number
are widely used.

=cut

sub parse ($$;%) {
  my $class = shift;
  my $field_body = shift;
  my $self = bless {option => {@_}}, $class;
  for (keys %DEFAULT) {$self->{option}->{$_} ||= $DEFAULT{$_}}
  if ($field_body =~ /$REG{M_control}/) {
    $self->{control} = $1;
    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;
  $field_body =~ s{$REG{FWS}$REG{M_was}}{
    $self->{was} = Message::Field::Subject->parse ($1);
    ''
  }ex;
  $self->{field_body} = $field_body;
  $self;
}

sub stringify ($;%) {
  my $self = shift;
  my %option = @_;
  $option{string_re} ||= $self->{option}->{string_re};
  $option{string_was} ||= $self->{option}->{string_was};
  my (%e) = &{$self->{option}->{hook_encode_string}} ($self, 
          $self->{field_body}, type => 'text');
  ($self->{is_reply}>0? $option{string_re}: '').$e{value}
  .(length $self->{was}? sprintf ($option{string_was}, $self->{was}): '');
}
sub as_string ($;%) {shift->stringify (@_)}

sub as_plain_string ($;%) {
  my $self = shift;
  my %option = @_;
  $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): '');
}

sub is ($$;$) {
  my $self = shift;
  my $valname = shift;
  my $newval = shift;
  if (defined $newval) {
    $self->{'is_'.$valname} = $newval;
  }
  $self->{'is_'.$valname};
}

sub option ($$;$) {
  my $self = shift;
  my $valname = shift;
  my $newval = shift;
  if (defined $newval) {
    $self->{option}->{$valname} = $newval;
  }
  $self->{option}->{$valname};
}

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

sub set ($$) {
  my $self = shift;
  my $new_string = shift;
  $self->{field_body} = $new_string;
  $self;
}

sub set_new ($$) {
  my $self = shift;
  my $new_string = shift;
  $self->was->{field_body} = $self->{field_body};
  $self->{was}->{is_reply} = $self->{is_reply};
  $self->{was}->{option}   = {%{$self->{option}}};
  $self->{field_body} = $new_string;
  $self->{is_reply} = -1;
  $self;
}

=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>.

=cut

1;
1	wakaba	1.1
2			=head1 NAME
3
4			Message::Field::Subject Perl module
5
6			=head1 DESCRIPTION
7
8			Perl module for RFC 822/2822 C<Subject> C<field>.
9
10			=cut
11
12			package Message::Field::Subject;
13			require 5.6.0;
14			use strict;
15			use re 'eval';
16			use vars qw(%DEFAULT %REG $VERSION);
17	wakaba	1.4	$VERSION=do{my @r=(q$Revision: 1.3 $=~/\d+/g);sprintf "%d."."%02d" x $#r,@r};
18	wakaba	1.3	require Message::Util;
19	wakaba	1.1
20			use overload '""' => sub {shift->stringify};
21			$REG{FWS} = qr/[\x09\x20]*/;
22	wakaba	1.2	$REG{re} = qr/(?:[Rr][Ee]\|[Ss][Vv])\^?\[?[0-9]*\]?:/;
23	wakaba	1.1	$REG{fwd} = qr/[Ff][Ww][Dd]?:/;
24			$REG{ml} = qr/[(\[][A-Za-z0-9._-]+[\x20:-][0-9]+[)\]]/;
25			$REG{M_ml} = qr/[(\[]([A-Za-z0-9._-]+)[\x20:-]([0-9]+)[)\]]/;
26			$REG{prefix} = qr/(?:$REG{re}\|$REG{fwd}\|$REG{ml})(?:$REG{FWS}(?:$REG{re}\|$REG{fwd}\|$REG{ml}))*/;
27			$REG{M_control} = qr/^cmsg$REG{FWS}([\x00-\xFF]*)$/;
28			$REG{M_was} = qr/\([Ww][Aa][Ss]:? ([\x00-\xFF]+)\)$REG{FWS}$/;
29
30			%DEFAULT = (
31	wakaba	1.3	encoding_after_encode => '*default',
32			encoding_before_decode => '*default',
33			hook_encode_string => #sub {shift; (value => shift, @_)},
34			\&Message::Util::encode_header_string,
35			hook_decode_string => #sub {shift; (value => shift, @_)},
36			\&Message::Util::decode_header_string,
37	wakaba	1.1	string_re => 'Re: ',
38			string_was => ' (was: %s)',
39			);
40
41			=head2 Message::Field::Subject->new ()
42
43			Returns empty subject object.
44
45			=cut
46
47			sub new ($;%) {
48			my $class = shift;
49			my $self = bless {option => {@_}}, $class;
50			for (keys %DEFAULT) {$self->{option}->{$_} \|\|= $DEFAULT{$_}}
51			$self;
52			}
53
54			=head2 Message::Field::Subject->parse ($unfolded_field_body)
55
56			Parses subject C<field-body>. Even C<Subject> is unstructured
57			field body, "Re: " prefix or mail-list name and number
58			are widely used.
59
60			=cut
61
62			sub parse ($$;%) {
63			my $class = shift;
64			my $field_body = shift;
65			my $self = bless {option => {@_}}, $class;
66			for (keys %DEFAULT) {$self->{option}->{$_} \|\|= $DEFAULT{$_}}
67			if ($field_body =~ /$REG{M_control}/) {
68			$self->{control} = $1;
69			return $self;
70			}
71	wakaba	1.3	my %s = &{$self->{option}->{hook_decode_string}} ($self, $field_body,
72			type => 'text');
73			$field_body = $s{value};
74	wakaba	1.1	$field_body =~ s{^$REG{FWS}($REG{prefix})$REG{FWS}}{
75			my $prefix = $1;
76			$self->{is_reply} = 1 if $prefix =~ /$REG{re}/;
77			$self->{is_foward} = 1 if $prefix =~ /$REG{fwd}/;
78			if ($prefix =~ /$REG{M_ml}/) {
79			($self->{ml_name}, $self->{ml_count}) = ($1, $2);
80			}
81			''
82			}ex;
83			$field_body =~ s{$REG{FWS}$REG{M_was}}{
84			$self->{was} = Message::Field::Subject->parse ($1);
85			''
86			}ex;
87			$self->{field_body} = $field_body;
88			$self;
89			}
90
91			sub stringify ($;%) {
92			my $self = shift;
93			my %option = @_;
94			$option{string_re} \|\|= $self->{option}->{string_re};
95			$option{string_was} \|\|= $self->{option}->{string_was};
96	wakaba	1.3	my (%e) = &{$self->{option}->{hook_encode_string}} ($self,
97			$self->{field_body}, type => 'text');
98			($self->{is_reply}>0? $option{string_re}: '').$e{value}
99			.(length $self->{was}? sprintf ($option{string_was}, $self->{was}): '');
100	wakaba	1.1	}
101	wakaba	1.3	sub as_string ($;%) {shift->stringify (@_)}
102	wakaba	1.1
103	wakaba	1.3	sub as_plain_string ($;%) {
104	wakaba	1.1	my $self = shift;
105	wakaba	1.3	my %option = @_;
106			$option{string_re} \|\|= $self->{option}->{string_re};
107			$option{string_was} \|\|= $self->{option}->{string_was};
108			($self->{is_reply}>0? $option{string_re}: '').$self->{field_body}
109			.(length $self->{was}?
110			sprintf ($option{string_was}, $self->{was}->as_plain_string): '');
111	wakaba	1.1	}
112
113			sub is ($$;$) {
114			my $self = shift;
115			my $valname = shift;
116			my $newval = shift;
117			if (defined $newval) {
118			$self->{'is_'.$valname} = $newval;
119			}
120			$self->{'is_'.$valname};
121			}
122
123			sub option ($$;$) {
124			my $self = shift;
125			my $valname = shift;
126			my $newval = shift;
127			if (defined $newval) {
128			$self->{option}->{$valname} = $newval;
129			}
130			$self->{option}->{$valname};
131			}
132
133			sub was ($) {
134			my $self = shift;
135			if (ref $self->{was}) {
136			#
137			} elsif ($self->{was}) {
138			$self->{was} = Message::Field::Subject->parse ($self->{was});
139			} else {
140			$self->{was} = new Message::Field::Subject;
141			}
142			$self->{was};
143			}
144
145			sub set ($$) {
146			my $self = shift;
147			my $new_string = shift;
148			$self->{field_body} = $new_string;
149			$self;
150			}
151
152			sub set_new ($$) {
153			my $self = shift;
154			my $new_string = shift;
155			$self->was->{field_body} = $self->{field_body};
156			$self->{was}->{is_reply} = $self->{is_reply};
157			$self->{was}->{option} = {%{$self->{option}}};
158			$self->{field_body} = $new_string;
159			$self->{is_reply} = -1;
160			$self;
161			}
162
163			=head1 LICENSE
164
165			Copyright 2002 wakaba E<lt>w@suika.fam.cxE<gt>.
166
167			This program is free software; you can redistribute it and/or modify
168			it under the terms of the GNU General Public License as published by
169			the Free Software Foundation; either version 2 of the License, or
170			(at your option) any later version.
171
172			This program is distributed in the hope that it will be useful,
173			but WITHOUT ANY WARRANTY; without even the implied warranty of
174			MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
175			GNU General Public License for more details.
176
177			You should have received a copy of the GNU General Public License
178			along with this program; see the file COPYING. If not, write to
179			the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
180			Boston, MA 02111-1307, USA.
181
182			=head1 CHANGE
183
184			See F<ChangeLog>.
185
186			=cut
187
188			1;