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 = '1.00';

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 = (
  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;
  }
  $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};
  ($self->{is_reply}>0? $option{string_re}: '').
  $self->{field_body}.
  (length $self->{was}? sprintf ($option{string_was}, $self->{was}): '');
}

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

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 EXAMPLE


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