Message/Field/MsgID.pm


=head1 NAME

Message::Field::MsgID Perl module

=head1 DESCRIPTION

Perl module for RFC 822/2822 Message-ID C<field>.

This module supports message ID C<field-body>s defined
by : RFC 822, RFC 2822, RFC 850, RFC 1036, son-of-RFC1036,
RFC 1341, RFC 1521, RFC 2045, but does not support: 
RFC 724, RFC 733.

=cut

package Message::Field::MsgID;
require 5.6.0;
use strict;
use re 'eval';
use vars qw(%OPTION %REG $VERSION);
$VERSION=do{my @r=(q$Revision: 2.21 $=~/\d+/g);sprintf "%d."."%02d" x $#r,@r};
use overload '@{}' => sub {shift->{id}},
             '""' => sub {shift->stringify};

use Message::Field::MsgID::MsgID;
$REG{comment} = qr/\x28(?:\x5C[\x00-\xFF]|[\x00-\x0C\x0E-\x27\x2A-\x5B\x5D-\xFF]+|(??{$REG{comment}}))*\x29/;
$REG{quoted_string} = qr/\x22(?:\x5C[\x00-\xFF]|[\x00-\x0C\x0E-\x21\x23-\x5B\x5D-\xFF])*\x22/;
$REG{domain_literal} = qr/\x5B(?:\x5C[\x00-\xFF]|[\x00-\x0C\x0E-\x5A\x5E-\xFF])*\x5D/;

$REG{WSP} = qr/[\x20\x09]+/;
$REG{FWS} = qr/[\x20\x09]*/;
$REG{atext} = qr/[\x21\x23-\x27\x2A\x2B\x2D\x2F\x30-\x39\x3D\x3F\x41-\x5A\x5E-\x7E]+/;
$REG{dot_atom} = qr/$REG{atext}(?:$REG{FWS}\x2E$REG{FWS}$REG{atext})*/;
$REG{dot_word} = qr/(?:$REG{atext}|$REG{quoted_string})(?:$REG{FWS}\x2E$REG{FWS}(?:$REG{atext}|$REG{quoted_string}))*/;
$REG{phrase} = qr/(?:$REG{atext}|$REG{quoted_string})(?:$REG{atext}|$REG{quoted_string}|\.|$REG{FWS})*/;
$REG{addr_spec} = qr/$REG{dot_word}$REG{FWS}\x40$REG{FWS}(?:$REG{dot_atom}|$REG{domain_literal})/;
$REG{msg_id} = qr/<$REG{FWS}$REG{addr_spec}$REG{FWS}>/;
$REG{M_quoted_string} = qr/\x22((?:\x5C[\x00-\xFF]|[\x00-\x0C\x0E-\x21\x23-\x5B\x5D-\xFF])*)\x22/;
$REG{M_addr_spec} = qr/($REG{dot_word})$REG{FWS}\x40$REG{FWS}($REG{dot_atom}|$REG{domain_literal})/;

$REG{NON_atom} = qr/[^\x09\x20\x21\x23-\x27\x2A\x2B\x2D\x2F\x30-\x39\x3D\x3F\x41-\x5A\x5E-\x7E\x2E]/;

%OPTION = (
  one_id        => -1,
  field_name    => 'message-id',
  reduce_first  => 1,
  reduce_last   => 3,
  reduce_max    => 10,
);

sub _init_option ($$) {
  my $self = shift;
  my $field_name = shift;
  if ($field_name eq 'message-id' || $field_name eq 'content-id') {
    $self->{option}->{one_id} = 1;
  }
  $self;
}

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

Returns new MsgID object.

=cut

sub new ($;%) {
  my $self = bless {}, shift;
  my %option = @_;
  for (%OPTION) {$option{$_} ||= $OPTION{$_}}
  $self->{option} = \%option;
  $self->_init_option ($self->{option}->{field_name});
  $self;
}

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

Parses C<field-body>.

=cut

sub parse ($$;%) {
  my $self = bless {}, shift;
  my $field_body = shift;
  my %option = @_;
  for (%OPTION) {$option{$_} ||= $OPTION{$_}}
  $self->{option} = \%option;
  $self->_init_option ($self->{option}->{field_name});
  $field_body = $self->delete_comment ($field_body);
  @{$self->{id}} = $self->parse_msgid_list ($field_body);
  $self;
}

sub parse_msgid_list ($$) {
  my $self = shift;
  my $fb = shift;
  my @ids;
  $fb =~ s{($REG{msg_id})}{
    push @ids, Message::Field::MsgID::MsgID->parse ($1);
  }goex;
  @ids;
}

=head2 $self->id ()

Return address list in the format described in
L<$self-E<gt>parse_address_list ()>.

=cut

sub id ($) {@{shift->{id}}}

=head2 $self->add ($msg_id, [%option])

Adds an msg-id to C<$self>.

Note that this method (and other methods) does not check
whether $msg_id is valid or not (It is only checked
if C<msg-id> is sorounded by angle blankets).

=cut

sub add ($;$%) {
  my $self = shift;
  my ($msg_id, %option) = @_;
  if (!ref $msg_id) {
    $msg_id = Message::Field::MsgID::MsgID->parse ($msg_id, %option);
  }
  push @{$self->{id}}, $msg_id;
  $self;
}

sub add_new ($;%) {
  my $self = shift;
  my (%option) = @_;
  my $msg_id = Message::Field::MsgID::MsgID->new (%option);
  push @{$self->{id}}, $msg_id if length $msg_id;
  $self;
}

sub reduce ($;%) {
  my $self = shift;
  my %option = @_;
  $option{reduce_max} ||= $self->{option}->{reduce_max};
  $option{reduce_first} ||= $self->{option}->{reduce_first};
  $option{reduce_last} ||= $self->{option}->{reduce_last};
  return $self if $#{$self->{id}}+1 <= $option{reduce_max};
  return $self if $#{$self->{id}}+1 <= $option{reduce_top}+$option{reduce_last};
  my @nid;
  push @nid, @{$self->{id}}[0..$option{reduce_first}-1];
  push @nid, @{$self->{id}}[-$option{reduce_last}..-1];
  $self->{id} = \@nid;
  $self;
}

sub stringify ($;%) {
  my $self = shift;
  my %option = @_;  
  $option{one_id} ||= $self->{option}->{one_id};
  $self->_delete_empty ();
  if ($option{one_id}>0) {
    $self->{id}->[0] || '';
  } else {
    join ' ', @{$self->{id}};
  }
}

sub _delete_empty ($) {
  my $self = shift;
  my @nid;
  for my $id (@{$self->{id}}) {push @nid, $id if $id}
  $self->{id} = \@nid;
}


=head2 $self->unquote_quoted_string ($string)

Unquote C<quoted-string>.  Get rid of C<DQUOTE>s and
C<REVERSED SOLIDUS> included in C<quoted-pair>.
This method is intended for internal use.

=cut

sub unquote_quoted_string ($$) {
  my $self = shift;
  my $quoted_string = shift;
  $quoted_string =~ s{$REG{M_quoted_string}}{
    my $qtext = $1;
    $qtext =~ s/\x5C([\x00-\xFF])/$1/g;
    $qtext;
  }goex;
  $quoted_string;
}

=head2 $self->delete_comment ($field_body)

Remove all C<comment> in given strictured C<field-body>.
This method is intended to be used for internal process.

=cut

sub delete_comment ($$) {
  my $self = shift;
  my $body = shift;
  $body =~ s{($REG{quoted_string}|$REG{domain_literal})|$REG{comment}}{
    my $o = $1;  $o? $o : ' ';
  }gex;
  $body;
}

=head1 EXAMPLE

  ## Compose field-body for To: field.
  
  use Message::Field::Address;
  my $addr = new Message::Field::Address;
  $addr->add ('foo@example.org', name => 'Mr. foo bar');
  $addr->add ('webmaster@example.org', group => 'administrators');
  $addr->add ('postmaster@example.org', group => 'administrators');
  
  my $field_body = $addr->stringify ();


  ## Output parsed address-list tree.
  
  use Message::Field::Address;
  my $addr = Message::Field::Address->parse ($field_body);
  
  for my $i (@$addr) {
    if ($i->{type} eq 'group') {
      print "\x40 $i->{display_name}: \n";
      for my $j (@{$i->{address}}) {
        print "\t- $j->{display_name} <$j->{route}$j->{addr_spec}>\n";
      }
    } else {
      print "- $i->{display_name} <$i->{route}$i->{addr_spec}>\n";
    }
  }

=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: 2002/03/16 01:26:30 $

=cut

1;
1	wakaba	1.1
2			=head1 NAME
3
4			Message::Field::MsgID Perl module
5
6			=head1 DESCRIPTION
7
8			Perl module for RFC 822/2822 Message-ID C<field>.
9
10			This module supports message ID C<field-body>s defined
11			by : RFC 822, RFC 2822, RFC 850, RFC 1036, son-of-RFC1036,
12			RFC 1341, RFC 1521, RFC 2045, but does not support:
13			RFC 724, RFC 733.
14
15			=cut
16
17			package Message::Field::MsgID;
18			require 5.6.0;
19			use strict;
20			use re 'eval';
21			use vars qw(%OPTION %REG $VERSION);
22			$VERSION=do{my @r=(q$Revision: 2.21 $=~/\d+/g);sprintf "%d."."%02d" x $#r,@r};
23			use overload '@{}' => sub {shift->{id}},
24			'""' => sub {shift->stringify};
25
26			use Message::Field::MsgID::MsgID;
27			$REG{comment} = qr/\x28(?:\x5C[\x00-\xFF]\|[\x00-\x0C\x0E-\x27\x2A-\x5B\x5D-\xFF]+\|(??{$REG{comment}}))*\x29/;
28			$REG{quoted_string} = qr/\x22(?:\x5C[\x00-\xFF]\|[\x00-\x0C\x0E-\x21\x23-\x5B\x5D-\xFF])*\x22/;
29			$REG{domain_literal} = qr/\x5B(?:\x5C[\x00-\xFF]\|[\x00-\x0C\x0E-\x5A\x5E-\xFF])*\x5D/;
30
31			$REG{WSP} = qr/[\x20\x09]+/;
32			$REG{FWS} = qr/[\x20\x09]*/;
33			$REG{atext} = qr/[\x21\x23-\x27\x2A\x2B\x2D\x2F\x30-\x39\x3D\x3F\x41-\x5A\x5E-\x7E]+/;
34			$REG{dot_atom} = qr/$REG{atext}(?:$REG{FWS}\x2E$REG{FWS}$REG{atext})*/;
35			$REG{dot_word} = qr/(?:$REG{atext}\|$REG{quoted_string})(?:$REG{FWS}\x2E$REG{FWS}(?:$REG{atext}\|$REG{quoted_string}))*/;
36			$REG{phrase} = qr/(?:$REG{atext}\|$REG{quoted_string})(?:$REG{atext}\|$REG{quoted_string}\|\.\|$REG{FWS})*/;
37			$REG{addr_spec} = qr/$REG{dot_word}$REG{FWS}\x40$REG{FWS}(?:$REG{dot_atom}\|$REG{domain_literal})/;
38			$REG{msg_id} = qr/<$REG{FWS}$REG{addr_spec}$REG{FWS}>/;
39			$REG{M_quoted_string} = qr/\x22((?:\x5C[\x00-\xFF]\|[\x00-\x0C\x0E-\x21\x23-\x5B\x5D-\xFF])*)\x22/;
40			$REG{M_addr_spec} = qr/($REG{dot_word})$REG{FWS}\x40$REG{FWS}($REG{dot_atom}\|$REG{domain_literal})/;
41
42			$REG{NON_atom} = qr/[^\x09\x20\x21\x23-\x27\x2A\x2B\x2D\x2F\x30-\x39\x3D\x3F\x41-\x5A\x5E-\x7E\x2E]/;
43
44			%OPTION = (
45			one_id => -1,
46			field_name => 'message-id',
47			reduce_first => 1,
48			reduce_last => 3,
49			reduce_max => 10,
50			);
51
52			sub _init_option ($$) {
53			my $self = shift;
54			my $field_name = shift;
55			if ($field_name eq 'message-id' \|\| $field_name eq 'content-id') {
56			$self->{option}->{one_id} = 1;
57			}
58			$self;
59			}
60
61			=head2 Message::Field::MsgID->new ()
62
63			Returns new MsgID object.
64
65			=cut
66
67			sub new ($;%) {
68			my $self = bless {}, shift;
69			my %option = @_;
70			for (%OPTION) {$option{$_} \|\|= $OPTION{$_}}
71			$self->{option} = \%option;
72			$self->_init_option ($self->{option}->{field_name});
73			$self;
74			}
75
76			=head2 Message::Field::MsgID->parse ($unfolded_field_body)
77
78			Parses C<field-body>.
79
80			=cut
81
82			sub parse ($$;%) {
83			my $self = bless {}, shift;
84			my $field_body = shift;
85			my %option = @_;
86			for (%OPTION) {$option{$_} \|\|= $OPTION{$_}}
87			$self->{option} = \%option;
88			$self->_init_option ($self->{option}->{field_name});
89			$field_body = $self->delete_comment ($field_body);
90			@{$self->{id}} = $self->parse_msgid_list ($field_body);
91			$self;
92			}
93
94			sub parse_msgid_list ($$) {
95			my $self = shift;
96			my $fb = shift;
97			my @ids;
98			$fb =~ s{($REG{msg_id})}{
99			push @ids, Message::Field::MsgID::MsgID->parse ($1);
100			}goex;
101			@ids;
102			}
103
104			=head2 $self->id ()
105
106			Return address list in the format described in
107			L<$self-E<gt>parse_address_list ()>.
108
109			=cut
110
111			sub id ($) {@{shift->{id}}}
112
113			=head2 $self->add ($msg_id, [%option])
114
115			Adds an msg-id to C<$self>.
116
117			Note that this method (and other methods) does not check
118			whether $msg_id is valid or not (It is only checked
119			if C<msg-id> is sorounded by angle blankets).
120
121			=cut
122
123			sub add ($;$%) {
124			my $self = shift;
125			my ($msg_id, %option) = @_;
126			if (!ref $msg_id) {
127			$msg_id = Message::Field::MsgID::MsgID->parse ($msg_id, %option);
128			}
129			push @{$self->{id}}, $msg_id;
130			$self;
131			}
132
133			sub add_new ($;%) {
134			my $self = shift;
135			my (%option) = @_;
136			my $msg_id = Message::Field::MsgID::MsgID->new (%option);
137			push @{$self->{id}}, $msg_id if length $msg_id;
138			$self;
139			}
140
141			sub reduce ($;%) {
142			my $self = shift;
143			my %option = @_;
144			$option{reduce_max} \|\|= $self->{option}->{reduce_max};
145			$option{reduce_first} \|\|= $self->{option}->{reduce_first};
146			$option{reduce_last} \|\|= $self->{option}->{reduce_last};
147			return $self if $#{$self->{id}}+1 <= $option{reduce_max};
148			return $self if $#{$self->{id}}+1 <= $option{reduce_top}+$option{reduce_last};
149			my @nid;
150			push @nid, @{$self->{id}}[0..$option{reduce_first}-1];
151			push @nid, @{$self->{id}}[-$option{reduce_last}..-1];
152			$self->{id} = \@nid;
153			$self;
154			}
155
156			sub stringify ($;%) {
157			my $self = shift;
158			my %option = @_;
159			$option{one_id} \|\|= $self->{option}->{one_id};
160			$self->_delete_empty ();
161			if ($option{one_id}>0) {
162			$self->{id}->[0] \|\| '';
163			} else {
164			join ' ', @{$self->{id}};
165			}
166			}
167
168			sub _delete_empty ($) {
169			my $self = shift;
170			my @nid;
171			for my $id (@{$self->{id}}) {push @nid, $id if $id}
172			$self->{id} = \@nid;
173			}
174
175
176			=head2 $self->unquote_quoted_string ($string)
177
178			Unquote C<quoted-string>. Get rid of C<DQUOTE>s and
179			C<REVERSED SOLIDUS> included in C<quoted-pair>.
180			This method is intended for internal use.
181
182			=cut
183
184			sub unquote_quoted_string ($$) {
185			my $self = shift;
186			my $quoted_string = shift;
187			$quoted_string =~ s{$REG{M_quoted_string}}{
188			my $qtext = $1;
189			$qtext =~ s/\x5C([\x00-\xFF])/$1/g;
190			$qtext;
191			}goex;
192			$quoted_string;
193			}
194
195			=head2 $self->delete_comment ($field_body)
196
197			Remove all C<comment> in given strictured C<field-body>.
198			This method is intended to be used for internal process.
199
200			=cut
201
202			sub delete_comment ($$) {
203			my $self = shift;
204			my $body = shift;
205			$body =~ s{($REG{quoted_string}\|$REG{domain_literal})\|$REG{comment}}{
206			my $o = $1; $o? $o : ' ';
207			}gex;
208			$body;
209			}
210
211			=head1 EXAMPLE
212
213			## Compose field-body for To: field.
214
215			use Message::Field::Address;
216			my $addr = new Message::Field::Address;
217			$addr->add ('foo@example.org', name => 'Mr. foo bar');
218			$addr->add ('webmaster@example.org', group => 'administrators');
219			$addr->add ('postmaster@example.org', group => 'administrators');
220
221			my $field_body = $addr->stringify ();
222
223
224			## Output parsed address-list tree.
225
226			use Message::Field::Address;
227			my $addr = Message::Field::Address->parse ($field_body);
228
229			for my $i (@$addr) {
230			if ($i->{type} eq 'group') {
231			print "\x40 $i->{display_name}: \n";
232			for my $j (@{$i->{address}}) {
233			print "\t- $j->{display_name} <$j->{route}$j->{addr_spec}>\n";
234			}
235			} else {
236			print "- $i->{display_name} <$i->{route}$i->{addr_spec}>\n";
237			}
238			}
239
240			=head1 LICENSE
241
242			Copyright 2002 wakaba E<lt>w@suika.fam.cxE<gt>.
243
244			This program is free software; you can redistribute it and/or modify
245			it under the terms of the GNU General Public License as published by
246			the Free Software Foundation; either version 2 of the License, or
247			(at your option) any later version.
248
249			This program is distributed in the hope that it will be useful,
250			but WITHOUT ANY WARRANTY; without even the implied warranty of
251			MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
252			GNU General Public License for more details.
253
254			You should have received a copy of the GNU General Public License
255			along with this program; see the file COPYING. If not, write to
256			the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
257			Boston, MA 02111-1307, USA.
258
259			=head1 CHANGE
260
261			See F<ChangeLog>.
262			$Date: 2002/03/16 01:26:30 $
263
264			=cut
265
266			1;