/[suikacvs]/messaging/manakai/lib/Message/Field/Addresses.pm
Suika

Diff of /messaging/manakai/lib/Message/Field/Addresses.pm

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.1 by wakaba, Wed May 8 09:11:31 2002 UTC revision 1.2 by wakaba, Tue May 14 13:42:40 2002 UTC
# Line 1  Line 1 
1    
2  =head1 NAME  =head1 NAME
3    
4  Message::Field::CSV --- Perl module for Internet message  Message::Field::Addresses --- Perl module for comma separated
5  field body consist of comma separated values  Internet mail address list
6    
7  =cut  =cut
8    
# Line 10  package Message::Field::Addresses; Line 10  package Message::Field::Addresses;
10  require 5.6.0;  require 5.6.0;
11  use strict;  use strict;
12  use re 'eval';  use re 'eval';
13  use vars qw(@ISA %REG $VERSION);  use vars qw(%DEFAULT @ISA %REG $VERSION);
14  $VERSION=do{my @r=(q$Revision$=~/\d+/g);sprintf "%d."."%02d" x $#r,@r};  $VERSION=do{my @r=(q$Revision$=~/\d+/g);sprintf "%d."."%02d" x $#r,@r};
15  require Message::Field::CSV;  require Message::Field::CSV;
16  push @ISA, qw(Message::Field::CSV);  push @ISA, qw(Message::Field::CSV);
17  *REG = \%Message::Field::CSV::REG;  %REG = %Message::Field::CSV::REG;
18          $REG{SC_angle_addr} = qr/<(?:$REG{quoted_string}|$REG{domain_literal}|$REG{comment}|[^\x22\x28\x5B\x3E])+>|<>/;          $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])+;/;          $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    
# Line 27  The following methods construct new obje Line 27  The following methods construct new obje
27  =cut  =cut
28    
29  ## Initialize of this class -- called by constructors  ## Initialize of this class -- called by constructors
30  sub _init ($;%) {    %DEFAULT = (
31    my $self = shift;      -_METHODS   => [qw|add count delete item display_name is_group value_type scan
32    my %options = @_;                         comment_add comment_count comment_delete comment_item|],
33    my %DEFAULT = (      -_MEMBERS   => [qw|group_name group_name_comment|],
     -_METHODS => [qw(add count delete item display_name is_group value_type scan)],  
34      -by => 'display-name',      ## Default key for item, delete,...      -by => 'display-name',      ## Default key for item, delete,...
35      -can_have_group     => 1,      -can_have_group     => 1,
36      #encoding_after_encode      #encoding_after_encode
# Line 42  sub _init ($;%) { Line 41  sub _init ($;%) {
41      #hook_encode_string      #hook_encode_string
42      #hook_decode_string      #hook_decode_string
43      -is_group   => 0,      -is_group   => 0,
44        #max
45      -output_comment     => 1,      -output_comment     => 1,
46      -output_group_name_comment  => 1,      -output_group_name_comment  => 1,
47      #parse_all      #parse_all
48      -remove_comment     => 0,   ## This option works for PARENT class      -remove_comment     => 0,   ## This option works for PARENT class
49      #value_type      #value_type
50    );    );
51    $self->SUPER::_init (%DEFAULT, %options);  sub _init ($;%) {
52      my $self = shift;
53      my %options = @_;
54      my $DEFAULT = Message::Util::make_clone (\%DEFAULT);
55      $self->SUPER::_init (%$DEFAULT, %options);
56      my (%mailbox, %group);
57        
58    $self->{option}->{value_type}->{'*group'} = ['Message::Field::Addresses',    $self->{option}->{can_have_group} = 0
59      {-is_group => 1}];      if $self->{option}->{field_param_name} eq 'group';
60    $self->{option}->{can_have_group} = 0 if $self->{option}->{field_param_name} eq '*group';    
61      my $field = $self->{option}->{field_name};
62      my $format = $self->{option}->{format};
63            ## rfc1036 = RFC 1036 + son-of-RFC1036
64      if ($field eq 'from' || $field eq 'resent-from') {
65        $self->{option}->{can_have_group} = 0;
66        $self->{option}->{max} = 1 if $format =~ /rfc1036|http/;
67      } elsif ($field eq 'mail-copies-to') {
68        $mailbox{-use_keyword} = 1;
69      } elsif ($field eq 'reply-to') {
70        $self->{option}->{can_have_group} = 0;
71        $self->{option}->{max} = 1 if $format =~ /rfc1036/;
72      } elsif ($field eq 'approved' || $field eq 'x-approved') {
73        $self->{option}->{can_have_group} = 0;
74        $self->{option}->{max} = 1 if $format =~ /news-rfc1036/;
75      }
76      
77      $self->{option}->{value_type}->{mailbox} = ['Message::Field::Mailbox',
78        {%mailbox}];
79      $self->{option}->{value_type}->{group} = ['Message::Field::Addresses',
80        {-is_group => 1, %group}];
81  }  }
82    
83  ## new, parse: Inherited  =item $addrs = Message::Field::Addresses->new ([%options])
84    
85    Constructs a new object.  You might pass some options as parameters
86    to the constructor.
87    
88    =cut
89    
90    ## Inherited
91    
92    =item $addrs = Message::Field::Addresses->parse ($field-body, [%options])
93    
94    Constructs a new object with given field body.  You might pass
95    some options as parameters to the constructor.
96    
97    =cut
98    
99    ## Inherited
100    
101  sub _parse_list ($$) {  sub _parse_list ($$) {
102    my $self = shift;    my $self = shift;
# Line 75  sub _parse_list ($$) { Line 116  sub _parse_list ($$) {
116    $fb =~ s{(?:$REG{quoted_string}|$REG{comment}|[^\x22\x28\x2C\x3A\x3C\x5B]|$REG{SC_group}|$REG{SC_angle_addr}|$REG{domain_literal})+}{    $fb =~ s{(?:$REG{quoted_string}|$REG{comment}|[^\x22\x28\x2C\x3A\x3C\x5B]|$REG{SC_group}|$REG{SC_angle_addr}|$REG{domain_literal})+}{
117      my $s = $&;  $s =~ s/^$REG{WSP}+//;  $s =~ s/$REG{WSP}+$//;      my $s = $&;  $s =~ s/^$REG{WSP}+//;  $s =~ s/$REG{WSP}+$//;
118      if ($s =~ /^(?:$REG{quoted_string}|$REG{comment}|[^\x22\x28\x2C\x3A\x3C\x5B])*:/) {      if ($s =~ /^(?:$REG{quoted_string}|$REG{comment}|[^\x22\x28\x2C\x3A\x3C\x5B])*:/) {
119        $s = $self->_parse_value ('*group' => $s) if $self->{option}->{parse_all};        $s = $self->_parse_value (group => $s) if $self->{option}->{parse_all};
120        $s = {type => '*group', value => $s};        $s = {type => 'group', value => $s};
121      } else {    ## address or keyword      } else {    ## address or keyword
122        $s = $self->_parse_value ('*mailbox' => $s) if $self->{option}->{parse_all};        $s = $self->_parse_value (mailbox => $s) if $self->{option}->{parse_all};
123        $s = {type => '*mailbox', value => $s};        $s = {type => 'mailbox', value => $s};
124      }      }
125      push @ids, $s;      push @ids, $s;
126    }goex;    }goex;
# Line 92  sub _parse_list ($$) { Line 133  sub _parse_list ($$) {
133    
134  =over 4  =over 4
135    
136    =item $addrs->add ({-name => $value}, $addr1, $addr2, $addr3,...)
137    
138    Adds mail address(es).
139    
140    First argument is hash reference to name/value pairs
141    of options.  This is optional.
142    
143    Following is list of additional items.  Each item
144    can be given as array reference.  An array reference
145    is interpreted as [$item-body, $item-option-name =>
146    $item-option-value, $name => $value,...].
147    Available item-options are:
148    
149    =over 2
150    
151    =item C<group>
152    
153    Group name which C<$item-body> belongs to.  If there
154    is no such name of group, new group is created.
155    
156    =item C<type> = 'mailbox' / 'group' (default 'group')
157    
158    Format of C<$item-body>.  If 'group' is specified,
159    <$item-body> is treated as RFC 2822 group.  Otherwise,
160    it is added as a mailbox.
161    
162    =back
163    
164    =item $count = $addrs->count ([%options])
165    
166    Returns the number of items.  A 'type' option is available.
167    For example, C<$addrs-E<gt>count (-type =E<gt> 'group')>
168    returns the number of groups.
169    
170    =item $addrs->delete ({%options}, $item-key, $key,...)
171    
172    Deletes items that are matched with (one of) given key.
173    C<{%options}> is optional.
174    
175    C<by> option is used to specify what sort of value given keys are.
176    C<display-name>, the default value, indicates
177    keys are display-name of items to be removed.
178    
179    For C<by> option, value C<index> is also available.
180    
181    C<type> option is also available.  Its value is 'mailbox'
182    and 'group'.  Default is both of them.
183    
184  =cut  =cut
185    
186  ## add, count, delete: Inherited  ## add, count, delete: Inherited
# Line 104  sub _add_array_check ($$\%) { Line 193  sub _add_array_check ($$\%) {
193      ($value, %$value_option) = @$value;      ($value, %$value_option) = @$value;
194    }    }
195    if (length $value_option->{group}) {    if (length $value_option->{group}) {
196      ## TODO:      my $g = $self->item ($value_option->{group}, -type => 'group');
197        delete $value_option->{group};
198        $g->add (Message::Util::make_clone ($option), [$value, %$value_option]);
199        (0);
200      } else {
201        my $type = $value_option->{type} || 'mailbox';
202        $value = $self->_parse_value ($type => $value) if $$option{parse};
203        $$option{parse} = 0;
204        (1, value => {type => $type, value => $value});
205    }    }
   $$option{parse} = 0;  
   (1, value => {type => 'address', value => $value});  
206  }  }
207    
208  sub _delete_match ($$$\%\%) {  sub _delete_match ($$$\%\%) {
# Line 115  sub _delete_match ($$$\%\%) { Line 210  sub _delete_match ($$$\%\%) {
210    my ($by, $i, $list, $option) = @_;    my ($by, $i, $list, $option) = @_;
211    return 0 unless ref $$i;  ## Already removed    return 0 unless ref $$i;  ## Already removed
212    return 0 if $$option{type} && $$i->{type} ne $$option{type};    return 0 if $$option{type} && $$i->{type} ne $$option{type};
   my $item = $$i->{value};  
213    if ($by eq 'display-name') {    if ($by eq 'display-name') {
214      $item = $self->_parse_value ($$i->{type}, $item);      $$i->{value} = $self->_parse_value ($$i->{type}, $$i->{value});
215      return 1 if ref $item && $$list{$item->display_name};      return 1 if ref $$i->{value} && $$list{$$i->{value}->display_name};
216    }    }
217    0;    0;
218  }  }
# Line 129  sub _item_return_value ($\$\%) { Line 223  sub _item_return_value ($\$\%) {
223    if (ref ${$_[1]}) {    if (ref ${$_[1]}) {
224      ${$_[1]}->{value};      ${$_[1]}->{value};
225    } else {    } else {
226      ${$_[1]} = $_[0]->_parse_value (${$_[1]});      ${$_[1]}->{value} = $_[0]->_parse_value (${$_[1]}->{type}, ${$_[1]}->{value});
227      ${$_[1]};      ${$_[1]}->{value};
228    }    }
229  }  }
230    
231    ## Returns returned (new created) item value    $name, \%option
232    sub _item_new_value ($$\%) {
233      my $type = $_[2]->{type} || 'mailbox';
234      my $v = $_[0]->_parse_value ($type, '');
235      $v->display_name ($_[1]) if ref $v && length $_[1] && $_[2]->{by} eq 'display-name';
236      {type => $type, value => $v};
237    }
238    
239  sub is_group ($;$) {  sub is_group ($;$) {
240    if (defined $_[1]) {    if (defined $_[1]) {
241      $_[0]->{option}->{is_group} = $_[1];      $_[0]->{option}->{is_group} = $_[1];
# Line 141  sub is_group ($;$) { Line 243  sub is_group ($;$) {
243    $_[0]->{option}->{is_group};    $_[0]->{option}->{is_group};
244  }  }
245    
246    sub have_group ($) {
247      my $self = shift;
248      for (@{$self->{$self->{option}->{_ARRAY_NAME}}}) {
249        return 1 if $_->{type} eq 'group';
250      }
251      0;
252    }
253    
254  sub display_name ($;$) {  sub display_name ($;$) {
255    if (defined $_[1]) {    if (defined $_[1]) {
256      $_[0]->{group_name} = $_[1];      $_[0]->{group_name} = $_[1];
# Line 148  sub display_name ($;$) { Line 258  sub display_name ($;$) {
258    $_[0]->{group_name};    $_[0]->{group_name};
259  }  }
260    
261    ##TODO: addr_spec
262    
263  ## stringify: Inherited  ## stringify: Inherited
264  #*as_string = \&stringify;  #*as_string = \&stringify;
265    
# Line 175  sub stringify ($;%) { Line 287  sub stringify ($;%) {
287    if ($option{is_group}) {    if ($option{is_group}) {
288      $m = $g . (length $m? ': ': ':') . $m . ';';      $m = $g . (length $m? ': ': ':') . $m . ';';
289    } else {    } else {
290      $m = $g . (length $m? ' ': '') . $m;      $m = $g . (length $g? ' ': '') . $m;
291    }    }
292      if ($option{output_comment} && !$option{output_group_name_comment}) {      if ($option{output_comment} && !$option{output_group_name_comment}) {
293        for (@{$self->{group_name_comment}}) {        for (@{$self->{group_name_comment}}) {
Legend:
Removed from v.1.1  
changed lines
  Added in v.1.2
admin@suikawiki.org
 ViewVC Help
Powered by ViewVC 1.1.24