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: 1.1 $=~/\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->{id} = [];
  $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->{id} = [];
  $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 ($) {
  my $self = shift;
  wantarray? @{$self->{id}}: $self->{id}->[0];
}

=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/20 09:56:26 $

=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	wakaba	1.2	$VERSION=do{my @r=(q$Revision: 1.1 $=~/\d+/g);sprintf "%d."."%02d" x $#r,@r};
23	wakaba	1.1	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	wakaba	1.2	$self->{id} = [];
72	wakaba	1.1	$self->{option} = \%option;
73			$self->_init_option ($self->{option}->{field_name});
74			$self;
75			}
76
77			=head2 Message::Field::MsgID->parse ($unfolded_field_body)
78
79			Parses C<field-body>.
80
81			=cut
82
83			sub parse ($$;%) {
84			my $self = bless {}, shift;
85			my $field_body = shift;
86			my %option = @_;
87			for (%OPTION) {$option{$_} \|\|= $OPTION{$_}}
88	wakaba	1.2	$self->{id} = [];
89	wakaba	1.1	$self->{option} = \%option;
90			$self->_init_option ($self->{option}->{field_name});
91			$field_body = $self->delete_comment ($field_body);
92			@{$self->{id}} = $self->parse_msgid_list ($field_body);
93			$self;
94			}
95
96			sub parse_msgid_list ($$) {
97			my $self = shift;
98			my $fb = shift;
99			my @ids;
100			$fb =~ s{($REG{msg_id})}{
101			push @ids, Message::Field::MsgID::MsgID->parse ($1);
102			}goex;
103			@ids;
104			}
105
106			=head2 $self->id ()
107
108			Return address list in the format described in
109			L<$self-E<gt>parse_address_list ()>.
110
111			=cut
112
113	wakaba	1.2	sub id ($) {
114			my $self = shift;
115			wantarray? @{$self->{id}}: $self->{id}->[0];
116			}
117	wakaba	1.1
118			=head2 $self->add ($msg_id, [%option])
119
120			Adds an msg-id to C<$self>.
121
122			Note that this method (and other methods) does not check
123			whether $msg_id is valid or not (It is only checked
124			if C<msg-id> is sorounded by angle blankets).
125
126			=cut
127
128			sub add ($;$%) {
129			my $self = shift;
130			my ($msg_id, %option) = @_;
131			if (!ref $msg_id) {
132			$msg_id = Message::Field::MsgID::MsgID->parse ($msg_id, %option);
133			}
134			push @{$self->{id}}, $msg_id;
135			$self;
136			}
137
138			sub add_new ($;%) {
139			my $self = shift;
140			my (%option) = @_;
141			my $msg_id = Message::Field::MsgID::MsgID->new (%option);
142			push @{$self->{id}}, $msg_id if length $msg_id;
143			$self;
144			}
145
146			sub reduce ($;%) {
147			my $self = shift;
148			my %option = @_;
149			$option{reduce_max} \|\|= $self->{option}->{reduce_max};
150			$option{reduce_first} \|\|= $self->{option}->{reduce_first};
151			$option{reduce_last} \|\|= $self->{option}->{reduce_last};
152			return $self if $#{$self->{id}}+1 <= $option{reduce_max};
153			return $self if $#{$self->{id}}+1 <= $option{reduce_top}+$option{reduce_last};
154			my @nid;
155			push @nid, @{$self->{id}}[0..$option{reduce_first}-1];
156			push @nid, @{$self->{id}}[-$option{reduce_last}..-1];
157			$self->{id} = \@nid;
158			$self;
159			}
160
161			sub stringify ($;%) {
162			my $self = shift;
163			my %option = @_;
164			$option{one_id} \|\|= $self->{option}->{one_id};
165			$self->_delete_empty ();
166			if ($option{one_id}>0) {
167			$self->{id}->[0] \|\| '';
168			} else {
169			join ' ', @{$self->{id}};
170			}
171			}
172
173			sub _delete_empty ($) {
174			my $self = shift;
175			my @nid;
176			for my $id (@{$self->{id}}) {push @nid, $id if $id}
177			$self->{id} = \@nid;
178			}
179
180
181			=head2 $self->unquote_quoted_string ($string)
182
183			Unquote C<quoted-string>. Get rid of C<DQUOTE>s and
184			C<REVERSED SOLIDUS> included in C<quoted-pair>.
185			This method is intended for internal use.
186
187			=cut
188
189			sub unquote_quoted_string ($$) {
190			my $self = shift;
191			my $quoted_string = shift;
192			$quoted_string =~ s{$REG{M_quoted_string}}{
193			my $qtext = $1;
194			$qtext =~ s/\x5C([\x00-\xFF])/$1/g;
195			$qtext;
196			}goex;
197			$quoted_string;
198			}
199
200			=head2 $self->delete_comment ($field_body)
201
202			Remove all C<comment> in given strictured C<field-body>.
203			This method is intended to be used for internal process.
204
205			=cut
206
207			sub delete_comment ($$) {
208			my $self = shift;
209			my $body = shift;
210			$body =~ s{($REG{quoted_string}\|$REG{domain_literal})\|$REG{comment}}{
211			my $o = $1; $o? $o : ' ';
212			}gex;
213			$body;
214			}
215
216			=head1 EXAMPLE
217
218			## Compose field-body for To: field.
219
220			use Message::Field::Address;
221			my $addr = new Message::Field::Address;
222			$addr->add ('foo@example.org', name => 'Mr. foo bar');
223			$addr->add ('webmaster@example.org', group => 'administrators');
224			$addr->add ('postmaster@example.org', group => 'administrators');
225
226			my $field_body = $addr->stringify ();
227
228
229			## Output parsed address-list tree.
230
231			use Message::Field::Address;
232			my $addr = Message::Field::Address->parse ($field_body);
233
234			for my $i (@$addr) {
235			if ($i->{type} eq 'group') {
236			print "\x40 $i->{display_name}: \n";
237			for my $j (@{$i->{address}}) {
238			print "\t- $j->{display_name} <$j->{route}$j->{addr_spec}>\n";
239			}
240			} else {
241			print "- $i->{display_name} <$i->{route}$i->{addr_spec}>\n";
242			}
243			}
244
245			=head1 LICENSE
246
247			Copyright 2002 wakaba E<lt>w@suika.fam.cxE<gt>.
248
249			This program is free software; you can redistribute it and/or modify
250			it under the terms of the GNU General Public License as published by
251			the Free Software Foundation; either version 2 of the License, or
252			(at your option) any later version.
253
254			This program is distributed in the hope that it will be useful,
255			but WITHOUT ANY WARRANTY; without even the implied warranty of
256			MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
257			GNU General Public License for more details.
258
259			You should have received a copy of the GNU General Public License
260			along with this program; see the file COPYING. If not, write to
261			the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
262			Boston, MA 02111-1307, USA.
263
264			=head1 CHANGE
265
266			See F<ChangeLog>.
267	wakaba	1.2	$Date: 2002/03/20 09:56:26 $
268	wakaba	1.1
269			=cut
270
271			1;