Message/Field/MsgIDs.pm


=head1 NAME

Message::Field::MsgIDs --- Perl module for Internet message
field bodies contains of Message-IDs, such as C<References:>,
C<In-Reply-To:> field bodies

=cut

package Message::Field::MsgIDs;
use strict;
use vars qw(@ISA %REG $VERSION);
$VERSION=do{my @r=(q$Revision: 1.2 $=~/\d+/g);sprintf "%d."."%02d" x $#r,@r};
require Message::Util;
require Message::Field::Structured;
push @ISA, qw(Message::Field::Structured);

use overload '""' => sub { $_[0]->stringify },
             '0+' => sub { $_[0]->count },
             '.=' => sub { $_[0]->add ($_[1]); $_[0] },
             fallback => 1;

*REG = \%Message::Util::REG;
## Inherited: comment, quoted_string, domain_literal
        ## WSP, FWS, phrase, NON_atom
        ## msg_id
        ## M_quoted_string


=head1 CONSTRUCTORS

The following methods construct new objects:

=over 4

=cut

## Initialize of this class -- called by constructors
sub _init ($;%) {
  my $self = shift;
  my %options = @_;
  my %DEFAULT = (
    -_ARRAY_NAME        => 'value',
    #dont_croak
    #encoding_after_encode
    #encoding_before_decode
    #field_param_name
    #field_name
    #format
    #hook_encode_string
    #hook_decode_string
    -output_comment     => 1,
    -output_phrase      => 0,
    -parse      => 1,   ## Default value for add method
    -parse_all  => 1,
    -reduce_save_last   => 3,
    -reduce_save_change_subject => 1,
    -reduce_save_top    => 1,
    -reduce_max_count   => 21,
    -separator  => ' ',
  );
  $self->SUPER::_init (%DEFAULT, %options);
  $self->{option}->{value_type}->{'*msg-id'} = ['Message::Field::MsgID'];
  #$self->{option}->{value_type}->{'*phrase'} = [':none:'];
  #$self->{option}->{value_type}->{'*comment'} = [':none:'];
  
  ## Initial value(s)
  if (ref $options{value} eq 'ARRAY') {
    $self->add (@{$options{value}});
  } elsif ($options{value}) {
    $self->add ($options{value});
  }
}

=item $id = Message::Field::MsgIDs->new ([%options])

Constructs a new object.  You might pass some options as parameters 
to the constructor.

=cut

## Inherited

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

Constructs a new 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 $body = shift;
  $self->_init (@_);
  my (@ids, @idc);
  ($body, @idc) = $self->Message::Util::delete_comment_to_array ($body);
  $body =~ s{($REG{msg_id})|($REG{atext_dot})|($REG{quoted_string})}{
    my ($msgid, $atom, $qstr) = ($1, $2, $3);
    if ($msgid) {
      $msgid = $self->_parse_value ('*msg-id' => $msgid)
        if $self->{option}->{parse_all};
      push @ids, {value => $msgid, type => 'msg-id'};
    } elsif ($atom) {
      my %s = &{$self->{option}->{hook_decode_string}} ($self, $atom,
                type => 'phrase/atom');
      push @ids, {value => $s{value}, type => 'phrase'};
    } else {
      $qstr = Message::Util::unquote_quoted_string ($qstr);
      my %s = &{$self->{option}->{hook_decode_string}} ($self, $qstr,
                type => 'phrase/quoted_string');
      push @ids, {value => $s{value}, type => 'phrase'};
    }
  }goex;
  push @{$self->{value}}, @ids, map {{value => $_, type => 'comment'}} @idc;
  $self;
}

=head1 METHODS

=over 4

=cut

## add: Inherited

sub _add_array_check ($$\%) {
  my $self = shift;
  my ($value, $option) = @_;
  my $value_option = {};
  if (ref $value eq 'ARRAY') {
    ($value, %$value_option) = @$value;
  }
  $value_option->{type} ||= 'msg-id';
  if ($value_option->{type} eq 'msg-id') {
    if ($$option{validate} && $value !~ /^$REG{msg_id}$/) {
      if ($$option{dont_croak}) {
        return (0);
      } else {
        Carp::croak qq{add: $value: Invalid msg-id};
      }
    }
    $value = $self->_parse_value ('*msg-id' => $value) if $$option{parse};
  }
  (1, $value => {value => $value, type => $value_option->{type}});
}

## count: Inherited

## Delete empty items
sub _delete_empty ($) {
  my $self = shift;
  $self->{value} = [grep {ref $_ && length $_->{value}} @{$self->{value}}];
  $self;
}

sub reduce ($;%) {
  my $self = shift;
  my %p = @_; my %option = %{$self->{option}};
  for (grep {/^-/} keys %p) {$option{substr ($_, 1)} = $p{$_}}
  return $self if $#{$self->{value}}+1 <= $option{reduce_max_count};
  return $self if $#{$self->{value}}+1 <= $option{reduce_save_top}
                                        + $option{reduce_save_last};
  my @nid;      ## By this operation, non-msg-id values are losted.
  $self->{value} = [grep {ref $_ && $_->{type} eq 'msg-id'} @{$self->{value}}];
  push @nid, @{$self->{value}}[0..$option{reduce_save_top}-1];
  push @nid, grep {$_->{value} =~ '-_-@'} @{$self->{value}}
    [$option{reduce_save_top}..($#{$self->{value}} - $option{reduce_save_last})]
    if $option{reduce_save_change_subject};
  push @nid, @{$self->{value}}[-$option{reduce_save_last}..-1];
  $self->{value} = \@nid;
  $self;
}

sub stringify ($;%) {
  my $self = shift;
  my %p = @_; my %option = %{$self->{option}};
  for (grep {/^-/} keys %p) {$option{substr ($_, 1)} = $p{$_}}
  $self->_delete_empty;
  join $option{separator}, grep {length $_} map {
    my $v = '';
    if ($_->{type} eq 'msg-id') {
      $v = $_->{value};
    } elsif ($_->{type} eq 'phrase') {
      if ($option{output_phrase}) {
        my %e = &{$self->{option}->{hook_encode_string}} ($self, 
           $_->{value}, type => 'phrase');
        $v = Message::Util::quote_unsafe_string ($e{value},
           unsafe => 'NON_atext');
      } elsif ($option{output_comment}) {
        $v = '('. $self->Message::Util::encode_ccontent ($_->{value}) .')';
      }
    } elsif ($_->{type} eq 'comment') {
      if ($option{output_comment}) {
        $v = '('. $self->Message::Util::encode_ccontent ($_->{value}) .')';
      }
    }
    $v;
  } @{$self->{value}};
}
*as_string = \&stringify;

=item $option-value = $r->option ($option-name)

Gets option value.

=item $r->option ($option-name, $option-value, ...)

Set option value(s).  You can pass multiple option name-value pair
as parameter when setting.

=cut

## Inherited

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

Returns a copy of the object.

=cut

## Inherited

=head1 STANDARDS

This module supports formats defined by:

=over 2

=item RFC 822

=item RFC 850

=item RFC 1036

=item son-of-RFC1036

=item RFC 2822

=item usefor-atricle

=back

but doesn't support:

=over 2

=item RFC 724

=item RFC 733

=back

=head1 EXAMPLE

 require Message::Field::MsgIDs;
 my $m = new Message::Field::MsgIDs 
   value => [qw(<foo1@bar.example> <foo2@bar.example>),
             [q{parent messages}, type => 'comment']],
 ;
 print $m;      # <foo1@bar.example> <foo2@bar.example> (parent messages)

=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/05/08 09:11:31 $

=cut

1;
1
2	=head1 NAME
3
4	Message::Field::MsgIDs --- Perl module for Internet message
5	field bodies contains of Message-IDs, such as C<References:>,
6	C<In-Reply-To:> field bodies
7
8	=cut
9
10	package Message::Field::MsgIDs;
11	use strict;
12	use vars qw(@ISA %REG $VERSION);
13	$VERSION=do{my @r=(q$Revision: 1.2 $=~/\d+/g);sprintf "%d."."%02d" x $#r,@r};
14	require Message::Util;
15	require Message::Field::Structured;
16	push @ISA, qw(Message::Field::Structured);
17
18	use overload '""' => sub { $_[0]->stringify },
19	'0+' => sub { $_[0]->count },
20	'.=' => sub { $_[0]->add ($_[1]); $_[0] },
21	fallback => 1;
22
23	*REG = \%Message::Util::REG;
24	## Inherited: comment, quoted_string, domain_literal
25	## WSP, FWS, phrase, NON_atom
26	## msg_id
27	## M_quoted_string
28
29
30	=head1 CONSTRUCTORS
31
32	The following methods construct new objects:
33
34	=over 4
35
36	=cut
37
38	## Initialize of this class -- called by constructors
39	sub _init ($;%) {
40	my $self = shift;
41	my %options = @_;
42	my %DEFAULT = (
43	-_ARRAY_NAME => 'value',
44	#dont_croak
45	#encoding_after_encode
46	#encoding_before_decode
47	#field_param_name
48	#field_name
49	#format
50	#hook_encode_string
51	#hook_decode_string
52	-output_comment => 1,
53	-output_phrase => 0,
54	-parse => 1, ## Default value for add method
55	-parse_all => 1,
56	-reduce_save_last => 3,
57	-reduce_save_change_subject => 1,
58	-reduce_save_top => 1,
59	-reduce_max_count => 21,
60	-separator => ' ',
61	);
62	$self->SUPER::_init (%DEFAULT, %options);
63	$self->{option}->{value_type}->{'*msg-id'} = ['Message::Field::MsgID'];
64	#$self->{option}->{value_type}->{'*phrase'} = [':none:'];
65	#$self->{option}->{value_type}->{'*comment'} = [':none:'];
66
67	## Initial value(s)
68	if (ref $options{value} eq 'ARRAY') {
69	$self->add (@{$options{value}});
70	} elsif ($options{value}) {
71	$self->add ($options{value});
72	}
73	}
74
75	=item $id = Message::Field::MsgIDs->new ([%options])
76
77	Constructs a new object. You might pass some options as parameters
78	to the constructor.
79
80	=cut
81
82	## Inherited
83
84	=item $id = Message::Field::MsgIDs->parse ($field-body, [%options])
85
86	Constructs a new object with given field body. You might pass
87	some options as parameters to the constructor.
88
89	=cut
90
91	sub parse ($$;%) {
92	my $class = shift;
93	my $self = bless {}, $class;
94	my $body = shift;
95	$self->_init (@_);
96	my (@ids, @idc);
97	($body, @idc) = $self->Message::Util::delete_comment_to_array ($body);
98	$body =~ s{($REG{msg_id})\|($REG{atext_dot})\|($REG{quoted_string})}{
99	my ($msgid, $atom, $qstr) = ($1, $2, $3);
100	if ($msgid) {
101	$msgid = $self->_parse_value ('*msg-id' => $msgid)
102	if $self->{option}->{parse_all};
103	push @ids, {value => $msgid, type => 'msg-id'};
104	} elsif ($atom) {
105	my %s = &{$self->{option}->{hook_decode_string}} ($self, $atom,
106	type => 'phrase/atom');
107	push @ids, {value => $s{value}, type => 'phrase'};
108	} else {
109	$qstr = Message::Util::unquote_quoted_string ($qstr);
110	my %s = &{$self->{option}->{hook_decode_string}} ($self, $qstr,
111	type => 'phrase/quoted_string');
112	push @ids, {value => $s{value}, type => 'phrase'};
113	}
114	}goex;
115	push @{$self->{value}}, @ids, map {{value => $_, type => 'comment'}} @idc;
116	$self;
117	}
118
119	=head1 METHODS
120
121	=over 4
122
123	=cut
124
125	## add: Inherited
126
127	sub _add_array_check ($$\%) {
128	my $self = shift;
129	my ($value, $option) = @_;
130	my $value_option = {};
131	if (ref $value eq 'ARRAY') {
132	($value, %$value_option) = @$value;
133	}
134	$value_option->{type} \|\|= 'msg-id';
135	if ($value_option->{type} eq 'msg-id') {
136	if ($$option{validate} && $value !~ /^$REG{msg_id}$/) {
137	if ($$option{dont_croak}) {
138	return (0);
139	} else {
140	Carp::croak qq{add: $value: Invalid msg-id};
141	}
142	}
143	$value = $self->_parse_value ('*msg-id' => $value) if $$option{parse};
144	}
145	(1, $value => {value => $value, type => $value_option->{type}});
146	}
147
148	## count: Inherited
149
150	## Delete empty items
151	sub _delete_empty ($) {
152	my $self = shift;
153	$self->{value} = [grep {ref $_ && length $_->{value}} @{$self->{value}}];
154	$self;
155	}
156
157	sub reduce ($;%) {
158	my $self = shift;
159	my %p = @_; my %option = %{$self->{option}};
160	for (grep {/^-/} keys %p) {$option{substr ($_, 1)} = $p{$_}}
161	return $self if $#{$self->{value}}+1 <= $option{reduce_max_count};
162	return $self if $#{$self->{value}}+1 <= $option{reduce_save_top}
163	+ $option{reduce_save_last};
164	my @nid; ## By this operation, non-msg-id values are losted.
165	$self->{value} = [grep {ref $_ && $_->{type} eq 'msg-id'} @{$self->{value}}];
166	push @nid, @{$self->{value}}[0..$option{reduce_save_top}-1];
167	push @nid, grep {$_->{value} =~ '-_-@'} @{$self->{value}}
168	[$option{reduce_save_top}..($#{$self->{value}} - $option{reduce_save_last})]
169	if $option{reduce_save_change_subject};
170	push @nid, @{$self->{value}}[-$option{reduce_save_last}..-1];
171	$self->{value} = \@nid;
172	$self;
173	}
174
175	sub stringify ($;%) {
176	my $self = shift;
177	my %p = @_; my %option = %{$self->{option}};
178	for (grep {/^-/} keys %p) {$option{substr ($_, 1)} = $p{$_}}
179	$self->_delete_empty;
180	join $option{separator}, grep {length $_} map {
181	my $v = '';
182	if ($_->{type} eq 'msg-id') {
183	$v = $_->{value};
184	} elsif ($_->{type} eq 'phrase') {
185	if ($option{output_phrase}) {
186	my %e = &{$self->{option}->{hook_encode_string}} ($self,
187	$_->{value}, type => 'phrase');
188	$v = Message::Util::quote_unsafe_string ($e{value},
189	unsafe => 'NON_atext');
190	} elsif ($option{output_comment}) {
191	$v = '('. $self->Message::Util::encode_ccontent ($_->{value}) .')';
192	}
193	} elsif ($_->{type} eq 'comment') {
194	if ($option{output_comment}) {
195	$v = '('. $self->Message::Util::encode_ccontent ($_->{value}) .')';
196	}
197	}
198	$v;
199	} @{$self->{value}};
200	}
201	*as_string = \&stringify;
202
203	=item $option-value = $r->option ($option-name)
204
205	Gets option value.
206
207	=item $r->option ($option-name, $option-value, ...)
208
209	Set option value(s). You can pass multiple option name-value pair
210	as parameter when setting.
211
212	=cut
213
214	## Inherited
215
216	=item $clone = $r->clone ()
217
218	Returns a copy of the object.
219
220	=cut
221
222	## Inherited
223
224	=head1 STANDARDS
225
226	This module supports formats defined by:
227
228	=over 2
229
230	=item RFC 822
231
232	=item RFC 850
233
234	=item RFC 1036
235
236	=item son-of-RFC1036
237
238	=item RFC 2822
239
240	=item usefor-atricle
241
242	=back
243
244	but doesn't support:
245
246	=over 2
247
248	=item RFC 724
249
250	=item RFC 733
251
252	=back
253
254	=head1 EXAMPLE
255
256	require Message::Field::MsgIDs;
257	my $m = new Message::Field::MsgIDs
258	value => [qw(<foo1@bar.example> <foo2@bar.example>),
259	[q{parent messages}, type => 'comment']],
260	;
261	print $m; # <foo1@bar.example> <foo2@bar.example> (parent messages)
262
263	=head1 LICENSE
264
265	Copyright 2002 wakaba E<lt>w@suika.fam.cxE<gt>.
266
267	This program is free software; you can redistribute it and/or modify
268	it under the terms of the GNU General Public License as published by
269	the Free Software Foundation; either version 2 of the License, or
270	(at your option) any later version.
271
272	This program is distributed in the hope that it will be useful,
273	but WITHOUT ANY WARRANTY; without even the implied warranty of
274	MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
275	GNU General Public License for more details.
276
277	You should have received a copy of the GNU General Public License
278	along with this program; see the file COPYING. If not, write to
279	the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
280	Boston, MA 02111-1307, USA.
281
282	=head1 CHANGE
283
284	See F<ChangeLog>.
285	$Date: 2002/05/08 09:11:31 $
286
287	=cut
288
289	1;