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.3 $=~/\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/03/31 13:11:55 $

=cut

1;
1	wakaba	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.3 $=~/\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/03/31 13:11:55 $
286
287			=cut
288
289			1;