Message/Field/Addresses.pm


=head1 NAME

Message::Field::CSV --- Perl module for Internet message
field body consist of comma separated values

=cut

package Message::Field::Addresses;
require 5.6.0;
use strict;
use re 'eval';
use vars qw(@ISA %REG $VERSION);
$VERSION=do{my @r=(q$Revision: 1.8 $=~/\d+/g);sprintf "%d."."%02d" x $#r,@r};
require Message::Field::CSV;
push @ISA, qw(Message::Field::CSV);
*REG = \%Message::Field::CSV::REG;
        $REG{SC_angle_addr} = qr/<(?:$REG{quoted_string}|$REG{domain_literal}|$REG{comment}|[^\x22\x28\x5B\x3E])+>|<>/;
        $REG{SC_group} = qr/:(?:$REG{comment}|$REG{quoted_string}|(??{$REG{SC_group}})|$REG{domain_literal}|$REG{SC_angle_addr}|[^\x22\x28\x5B\x3A\x3E\x3B])+;/;

=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 = (
    -_METHODS => [qw(add count delete item display_name is_group value_type scan)],
    -by => 'display-name',      ## Default key for item, delete,...
    -can_have_group     => 1,
    #encoding_after_encode
    #encoding_before_decode
    #field_name
    #field_param_name
    #format
    #hook_encode_string
    #hook_decode_string
    -is_group   => 0,
    -output_comment     => 1,
    -output_group_name_comment  => 1,
    #parse_all
    -remove_comment     => 0,   ## This option works for PARENT class
    #value_type
  );
  $self->SUPER::_init (%DEFAULT, %options);
  
  $self->{option}->{value_type}->{'*group'} = ['Message::Field::Addresses',
    {-is_group => 1}];
  $self->{option}->{can_have_group} = 0 if $self->{option}->{field_param_name} eq '*group';
}

## new, parse: Inherited

sub _parse_list ($$) {
  my $self = shift;
  my $fb = shift;
  my @ids;
  if ($self->{option}->{is_group}) {
    $fb =~ s{^((?:$REG{quoted_string}|$REG{comment}|[^\x22\x28\x2C\x3A\x3C\x5B])+):}{
      my ($gname, @gcomment) = Message::Util::delete_comment_to_array ($self, $1);
      $self->{group_name} = Message::Util::decode_quoted_string ($self, $gname);
      $self->{group_name_comment} = \@gcomment;
    ''}gex;
    $fb =~ s{;((?:$REG{comment}|$REG{WSP})*)$}{
      my (undef, @gcomment) = Message::Util::delete_comment_to_array ($self, $1);
      $self->{comment} = \@gcomment;
    ''}gex;
  }
  $fb =~ s{(?:$REG{quoted_string}|$REG{comment}|[^\x22\x28\x2C\x3A\x3C\x5B]|$REG{SC_group}|$REG{SC_angle_addr}|$REG{domain_literal})+}{
    my $s = $&;  $s =~ s/^$REG{WSP}+//;  $s =~ s/$REG{WSP}+$//;
    if ($s =~ /^(?:$REG{quoted_string}|$REG{comment}|[^\x22\x28\x2C\x3A\x3C\x5B])*:/) {
      $s = $self->_parse_value ('*group' => $s) if $self->{option}->{parse_all};
      $s = {type => '*group', value => $s};
    } else {    ## address or keyword
      $s = $self->_parse_value ('*mailbox' => $s) if $self->{option}->{parse_all};
      $s = {type => '*mailbox', value => $s};
    }
    push @ids, $s;
  }goex;
  @ids;
}

=back

=head1 METHODS

=over 4

=cut

## add, count, delete: Inherited

sub _add_array_check ($$\%) {
  my $self = shift;
  my ($value, $option) = @_;
  my $value_option = {};
  if (ref $value eq 'ARRAY') {
    ($value, %$value_option) = @$value;
  }
  if (length $value_option->{group}) {
    ## TODO:
  }
  $$option{parse} = 0;
  (1, value => {type => 'address', value => $value});
}

sub _delete_match ($$$\%\%) {
  my $self = shift;
  my ($by, $i, $list, $option) = @_;
  return 0 unless ref $$i;  ## Already removed
  return 0 if $$option{type} && $$i->{type} ne $$option{type};
  my $item = $$i->{value};
  if ($by eq 'display-name') {
    $item = $self->_parse_value ($$i->{type}, $item);
    return 1 if ref $item && $$list{$item->display_name};
  }
  0;
}
*_item_match = \&_delete_match;

## Returns returned item value    \$item-value, \%option
sub _item_return_value ($\$\%) {
  if (ref ${$_[1]}) {
    ${$_[1]}->{value};
  } else {
    ${$_[1]} = $_[0]->_parse_value (${$_[1]});
    ${$_[1]};
  }
}

sub is_group ($;$) {
  if (defined $_[1]) {
    $_[0]->{option}->{is_group} = $_[1];
  }
  $_[0]->{option}->{is_group};
}

sub display_name ($;$) {
  if (defined $_[1]) {
    $_[0]->{group_name} = $_[1];
  }
  $_[0]->{group_name};
}

## stringify: Inherited
#*as_string = \&stringify;

sub stringify ($;%) {
  my $self = shift;
  my %o = @_;
  my %option = %{$self->{option}};
  for (grep {/^-/} keys %o) {$option{substr ($_, 1)} = $o{$_}}
  my $m = $self->SUPER::stringify (@_);
  my $g = '';
  if ($option{is_group}) {
    my %s = &{$option{hook_encode_string}} ($self, 
          $self->{group_name}, type => 'phrase');
    $g .= Message::Util::quote_unsafe_string
      ($s{value}, unsafe => 'NON_atext_wsp');
  }
  if ($option{output_comment} && $option{output_group_name_comment}) {
    if (!$option{is_group} && length $self->{group_name}) {
      $g .= ' ('. $self->Message::Util::encode_ccontent ($self->{group_name}) .':)';
    }
    for (@{$self->{group_name_comment}}) {
      $g .= ' ('. $self->Message::Util::encode_ccontent ($_) .')';
    }
  }
  if ($option{is_group}) {
    $m = $g . (length $m? ': ': ':') . $m . ';';
  } else {
    $m = $g . (length $m? ' ': '') . $m;
  }
    if ($option{output_comment} && !$option{output_group_name_comment}) {
      for (@{$self->{group_name_comment}}) {
        $m .= ' ('. $self->Message::Util::encode_ccontent ($_) .')';
      }
    }
    if ($option{output_comment}) {
      for (@{$self->{comment}}) {
        $m .= ' ('. $self->Message::Util::encode_ccontent ($_) .')';
      }
    }
  $m;
}
*as_string = \&stringify;
sub _stringify_item ($$\%) {
  my $self = shift;
  my $item = shift;
  my $option = shift;
  if (!$$option{can_have_group} && ref $item->{value}) {
    $item->{value}->stringify (-is_group => 0);
  } else {
    $item->{value};
  }
}

## option, value_type, clone, method_available: Inherited

=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/04/22 08:28:20 $

=cut

1;
1	wakaba	1.1
2			=head1 NAME
3
4			Message::Field::CSV --- Perl module for Internet message
5			field body consist of comma separated values
6
7			=cut
8
9			package Message::Field::Addresses;
10			require 5.6.0;
11			use strict;
12			use re 'eval';
13			use vars qw(@ISA %REG $VERSION);
14			$VERSION=do{my @r=(q$Revision: 1.8 $=~/\d+/g);sprintf "%d."."%02d" x $#r,@r};
15			require Message::Field::CSV;
16			push @ISA, qw(Message::Field::CSV);
17			*REG = \%Message::Field::CSV::REG;
18			$REG{SC_angle_addr} = qr/<(?:$REG{quoted_string}\|$REG{domain_literal}\|$REG{comment}\|[^\x22\x28\x5B\x3E])+>\|<>/;
19			$REG{SC_group} = qr/:(?:$REG{comment}\|$REG{quoted_string}\|(??{$REG{SC_group}})\|$REG{domain_literal}\|$REG{SC_angle_addr}\|[^\x22\x28\x5B\x3A\x3E\x3B])+;/;
20
21			=head1 CONSTRUCTORS
22
23			The following methods construct new objects:
24
25			=over 4
26
27			=cut
28
29			## Initialize of this class -- called by constructors
30			sub _init ($;%) {
31			my $self = shift;
32			my %options = @_;
33			my %DEFAULT = (
34			-_METHODS => [qw(add count delete item display_name is_group value_type scan)],
35			-by => 'display-name', ## Default key for item, delete,...
36			-can_have_group => 1,
37			#encoding_after_encode
38			#encoding_before_decode
39			#field_name
40			#field_param_name
41			#format
42			#hook_encode_string
43			#hook_decode_string
44			-is_group => 0,
45			-output_comment => 1,
46			-output_group_name_comment => 1,
47			#parse_all
48			-remove_comment => 0, ## This option works for PARENT class
49			#value_type
50			);
51			$self->SUPER::_init (%DEFAULT, %options);
52
53			$self->{option}->{value_type}->{'*group'} = ['Message::Field::Addresses',
54			{-is_group => 1}];
55			$self->{option}->{can_have_group} = 0 if $self->{option}->{field_param_name} eq '*group';
56			}
57
58			## new, parse: Inherited
59
60			sub _parse_list ($$) {
61			my $self = shift;
62			my $fb = shift;
63			my @ids;
64			if ($self->{option}->{is_group}) {
65			$fb =~ s{^((?:$REG{quoted_string}\|$REG{comment}\|[^\x22\x28\x2C\x3A\x3C\x5B])+):}{
66			my ($gname, @gcomment) = Message::Util::delete_comment_to_array ($self, $1);
67			$self->{group_name} = Message::Util::decode_quoted_string ($self, $gname);
68			$self->{group_name_comment} = \@gcomment;
69			''}gex;
70			$fb =~ s{;((?:$REG{comment}\|$REG{WSP})*)$}{
71			my (undef, @gcomment) = Message::Util::delete_comment_to_array ($self, $1);
72			$self->{comment} = \@gcomment;
73			''}gex;
74			}
75			$fb =~ s{(?:$REG{quoted_string}\|$REG{comment}\|[^\x22\x28\x2C\x3A\x3C\x5B]\|$REG{SC_group}\|$REG{SC_angle_addr}\|$REG{domain_literal})+}{
76			my $s = $&; $s =~ s/^$REG{WSP}+//; $s =~ s/$REG{WSP}+$//;
77			if ($s =~ /^(?:$REG{quoted_string}\|$REG{comment}\|[^\x22\x28\x2C\x3A\x3C\x5B])*:/) {
78			$s = $self->_parse_value ('*group' => $s) if $self->{option}->{parse_all};
79			$s = {type => '*group', value => $s};
80			} else { ## address or keyword
81			$s = $self->_parse_value ('*mailbox' => $s) if $self->{option}->{parse_all};
82			$s = {type => '*mailbox', value => $s};
83			}
84			push @ids, $s;
85			}goex;
86			@ids;
87			}
88
89			=back
90
91			=head1 METHODS
92
93			=over 4
94
95			=cut
96
97			## add, count, delete: Inherited
98
99			sub _add_array_check ($$\%) {
100			my $self = shift;
101			my ($value, $option) = @_;
102			my $value_option = {};
103			if (ref $value eq 'ARRAY') {
104			($value, %$value_option) = @$value;
105			}
106			if (length $value_option->{group}) {
107			## TODO:
108			}
109			$$option{parse} = 0;
110			(1, value => {type => 'address', value => $value});
111			}
112
113			sub _delete_match ($$$\%\%) {
114			my $self = shift;
115			my ($by, $i, $list, $option) = @_;
116			return 0 unless ref $$i; ## Already removed
117			return 0 if $$option{type} && $$i->{type} ne $$option{type};
118			my $item = $$i->{value};
119			if ($by eq 'display-name') {
120			$item = $self->_parse_value ($$i->{type}, $item);
121			return 1 if ref $item && $$list{$item->display_name};
122			}
123			0;
124			}
125			*_item_match = \&_delete_match;
126
127			## Returns returned item value \$item-value, \%option
128			sub _item_return_value ($\$\%) {
129			if (ref ${$_[1]}) {
130			${$_[1]}->{value};
131			} else {
132			${$_[1]} = $_[0]->_parse_value (${$_[1]});
133			${$_[1]};
134			}
135			}
136
137			sub is_group ($;$) {
138			if (defined $_[1]) {
139			$_[0]->{option}->{is_group} = $_[1];
140			}
141			$_[0]->{option}->{is_group};
142			}
143
144			sub display_name ($;$) {
145			if (defined $_[1]) {
146			$_[0]->{group_name} = $_[1];
147			}
148			$_[0]->{group_name};
149			}
150
151			## stringify: Inherited
152			#*as_string = \&stringify;
153
154			sub stringify ($;%) {
155			my $self = shift;
156			my %o = @_;
157			my %option = %{$self->{option}};
158			for (grep {/^-/} keys %o) {$option{substr ($_, 1)} = $o{$_}}
159			my $m = $self->SUPER::stringify (@_);
160			my $g = '';
161			if ($option{is_group}) {
162			my %s = &{$option{hook_encode_string}} ($self,
163			$self->{group_name}, type => 'phrase');
164			$g .= Message::Util::quote_unsafe_string
165			($s{value}, unsafe => 'NON_atext_wsp');
166			}
167			if ($option{output_comment} && $option{output_group_name_comment}) {
168			if (!$option{is_group} && length $self->{group_name}) {
169			$g .= ' ('. $self->Message::Util::encode_ccontent ($self->{group_name}) .':)';
170			}
171			for (@{$self->{group_name_comment}}) {
172			$g .= ' ('. $self->Message::Util::encode_ccontent ($_) .')';
173			}
174			}
175			if ($option{is_group}) {
176			$m = $g . (length $m? ': ': ':') . $m . ';';
177			} else {
178			$m = $g . (length $m? ' ': '') . $m;
179			}
180			if ($option{output_comment} && !$option{output_group_name_comment}) {
181			for (@{$self->{group_name_comment}}) {
182			$m .= ' ('. $self->Message::Util::encode_ccontent ($_) .')';
183			}
184			}
185			if ($option{output_comment}) {
186			for (@{$self->{comment}}) {
187			$m .= ' ('. $self->Message::Util::encode_ccontent ($_) .')';
188			}
189			}
190			$m;
191			}
192			*as_string = \&stringify;
193			sub _stringify_item ($$\%) {
194			my $self = shift;
195			my $item = shift;
196			my $option = shift;
197			if (!$$option{can_have_group} && ref $item->{value}) {
198			$item->{value}->stringify (-is_group => 0);
199			} else {
200			$item->{value};
201			}
202			}
203
204			## option, value_type, clone, method_available: Inherited
205
206			=head1 LICENSE
207
208			Copyright 2002 wakaba E<lt>w@suika.fam.cxE<gt>.
209
210			This program is free software; you can redistribute it and/or modify
211			it under the terms of the GNU General Public License as published by
212			the Free Software Foundation; either version 2 of the License, or
213			(at your option) any later version.
214
215			This program is distributed in the hope that it will be useful,
216			but WITHOUT ANY WARRANTY; without even the implied warranty of
217			MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
218			GNU General Public License for more details.
219
220			You should have received a copy of the GNU General Public License
221			along with this program; see the file COPYING. If not, write to
222			the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
223			Boston, MA 02111-1307, USA.
224
225			=head1 CHANGE
226
227			See F<ChangeLog>.
228			$Date: 2002/04/22 08:28:20 $
229
230			=cut
231
232			1;