File Coverage

blib/lib/Net/DRI/Data/ContactSet.pm
Criterion Covered Total %
statement 73 147 49.6
branch 27 82 32.9
condition 9 39 23.0
subroutine 12 20 60.0
pod 10 13 76.9
total 131 301 43.5


line stmt bran cond sub pod time code
1             ## Domain Registry Interface, Stores ordered list of contacts + type (registrant, admin, tech, bill, etc...)
2             ##
3             ## Copyright (c) 2005-2009,2011-2014 Patrick Mevzek . All rights reserved.
4             ##
5             ## This file is part of Net::DRI
6             ##
7             ## Net::DRI is free software; you can redistribute it and/or modify
8             ## it under the terms of the GNU General Public License as published by
9             ## the Free Software Foundation; either version 2 of the License, or
10             ## (at your option) any later version.
11             ##
12             ## See the LICENSE file that comes with this distribution for more details.
13             #########################################################################################
14              
15             package Net::DRI::Data::ContactSet;
16              
17 60     60   1081 use strict;
  60         109  
  60         2441  
18 60     60   283 use warnings;
  60         102  
  60         1876  
19              
20 60     60   719 use Net::DRI::Exception;
  60         100  
  60         1209  
21 60     60   869 use Net::DRI::Data::Contact;
  60         89  
  60         368  
22 60     60   1400 use Net::DRI::Util;
  60         110  
  60         83097  
23              
24             =pod
25              
26             =head1 NAME
27              
28             Net::DRI::Data::ContactSet - Handle an ordered collection of contacts for Net::DRI
29              
30             =head1 DESCRIPTION
31              
32             This class encapsulates a set of contacts, with associated types. For each type, it can stores as many contacts as needed.
33             Contacts are compared among themselves by calling the id() method on them. Thus all Contact classes
34             must define such a method, which returns a string.
35              
36             =head1 METHODS
37              
38             =head2 new()
39              
40             creates a new object
41              
42             =head2 types()
43              
44             returns the list of current types stored in this class
45              
46             =head2 has_type()
47              
48             returns 1 if the given type as first argument has some contacts in this object, 0 otherwise
49              
50             =head2 add()
51              
52             with the first argument being a contact, and the second (optional) a type, adds the contact
53             to the list of contacts for this type or all types (if no second argument). If the contact already exists
54             (same id()), it will be replaced when found. Returns the object itself.
55              
56             =head2 del()
57              
58             the opposite of add()
59              
60             =head2 rem()
61              
62             alias for del()
63              
64             =head2 clear()
65              
66             removes all contact currently associated to all types
67              
68             =head2 set()
69              
70             with an array ref as first argument, and a type (optional) as second, set the current list
71             of the given type (or all types) to be the list of contacts in first argument. Returns the object itself.
72              
73             =head2 get()
74              
75             returns list (in list context) or first element of list (in scalar context) for the type given as argument
76              
77             =head2 get_all()
78              
79             returns list of contacts, without duplicates, for all types
80              
81             =head1 SUPPORT
82              
83             For now, support questions should be sent to:
84              
85             Enetdri@dotandco.comE
86              
87             Please also see the SUPPORT file in the distribution.
88              
89             =head1 SEE ALSO
90              
91             http://www.dotandco.com/services/software/Net-DRI/
92              
93             =head1 AUTHOR
94              
95             Patrick Mevzek, Enetdri@dotandco.comE
96              
97             =head1 COPYRIGHT
98              
99             Copyright (c) 2005-2009,2011-2014 Patrick Mevzek .
100             All rights reserved.
101              
102             This program is free software; you can redistribute it and/or modify
103             it under the terms of the GNU General Public License as published by
104             the Free Software Foundation; either version 2 of the License, or
105             (at your option) any later version.
106              
107             See the LICENSE file that comes with this distribution for more details.
108              
109             =cut
110              
111             ################################################################################################################
112              
113             our $AUTOLOAD;
114              
115             sub new
116             {
117 4     4 1 3571 my ($class,@r)=@_;
118 4         8 my $self={ c => {} };
119 4         11 bless $self,$class;
120 4 100       10 if (@r)
121             {
122 3 100 66     17 @r=%{$r[0]} if defined $r[0] && ref $r[0] eq 'HASH';
  1         5  
123 3 50       11 Net::DRI::Exception::usererr_invalid_parameters('Invalid number of parameters passed') unless @r%2==0;
124 3         9 while(my ($ctype,$ids)=splice(@r,0,2))
125             {
126 7 100       14 foreach my $id (ref $ids eq 'ARRAY' ? @$ids : ($ids))
127             {
128 9 50       20 my $o=Net::DRI::Util::isa_contact($id) ? $id : Net::DRI::Data::Contact->new()->srid($id);
129 9         150 $self->add($o,$ctype);
130             }
131             }
132             }
133 4         9 return $self;
134             }
135              
136             sub types
137             {
138 2     2 1 248 my ($self)=@_;
139 2         2 my @r=sort { $a cmp $b } grep { @{$self->{c}->{$_}} } keys %{$self->{c}};
  2         4  
  3         2  
  3         7  
  2         7  
140 2         8 return @r;
141             }
142              
143             sub has_type
144             {
145 3     3 1 6 my ($self,$ctype)=@_;
146 3 100       10 return 0 unless defined $ctype;
147 2 100 66     10 return exists $self->{c}->{$ctype} && @{$self->{c}->{$ctype}} ? 1 : 0;
148             }
149              
150             sub is_empty
151             {
152 0     0 0 0 my $self=shift;
153 0         0 my @a=$self->types();
154 0 0       0 return (@a)? 0 : 1;
155             }
156              
157             sub _pos
158             {
159 9     9   9 my ($self,$t,$id)=@_;
160 9         9 my $c=$self->{c};
161 9         6 my $l=$#{$c->{$t}};
  9         12  
162 9 50 33     14 my @p=grep { my $i=$c->{$t}->[$_]->id(); (defined($i) && ($i eq $id))? 1 : 0 } (0..$l);
  3         7  
  3         13  
163 9 50       11 return $p[0] if @p;
164 9         14 return;
165             }
166              
167             sub add
168             {
169 9     9 1 10 my ($self,$cobj,$ctype)=@_;
170 9 50       15 return unless defined($cobj);
171 9         10 my $c=$self->{c};
172 9 100 66     37 $c->{$ctype}=[] if (defined($ctype) && !exists($c->{$ctype}));
173 9         21 my $id=$cobj->id();
174 9         24 foreach my $k (sort { $a cmp $b } keys %$c)
  7         10  
175             {
176 15 100 66     62 next if (defined($ctype) && ($k ne $ctype));
177 9 50       14 if ($id)
178             {
179 9         13 my $p=$self->_pos($k,$id);
180 9 50       20 if (defined($p))
181             {
182 0         0 $c->{$k}->[$p]=$cobj;
183 0         0 next;
184             }
185             }
186 9         7 push @{$c->{$k}},$cobj;
  9         16  
187             }
188 9         32 return $self;
189             }
190              
191             sub del
192             {
193 0     0 1 0 my ($self,$cobj,$ctype)=@_;
194 0 0       0 return unless defined($ctype);
195 0         0 my $c=$self->{c};
196 0 0 0     0 return if (defined($ctype) && !exists($c->{$ctype}));
197 0         0 my $id=$cobj->id();
198 0 0       0 return unless $id;
199 0         0 foreach my $k (sort { $a cmp $b } keys %$c)
  0         0  
200             {
201 0 0 0     0 next if (defined($ctype) && ($k ne $ctype));
202 0         0 my $p=$self->_pos($k,$id);
203 0 0       0 next unless defined($p);
204 0         0 splice(@{$c->{$k}},$p,1);
  0         0  
205             }
206 0         0 return $self;
207             }
208              
209 0     0 1 0 sub rem { my ($self,@args)=@_; return $self->del(@args); }
  0         0  
210              
211             sub clear
212             {
213 0     0 1 0 my ($self,$ctype)=@_;
214 0         0 return $self->set($ctype,[]);
215             }
216              
217             sub set
218             {
219 0     0 1 0 my ($self,$robj,$ctype)=@_;
220 0 0       0 return unless defined($robj);
221 0         0 my $c=$self->{c};
222 0 0 0     0 $c->{$ctype}=[] if (defined($ctype) && !exists($c->{$ctype}));
223 0         0 foreach my $k (sort { $a cmp $b } keys %$c)
  0         0  
224             {
225 0 0 0     0 next if (defined($ctype) && ($k ne $ctype));
226 0 0       0 $c->{$k}=(ref($robj) eq 'ARRAY')? $robj : [$robj];
227             }
228 0         0 return $self;
229             }
230              
231             sub get
232             {
233 6     6 1 10 my ($self,$ctype)=@_;
234 6 50       9 return unless defined $ctype;
235 6         9 my $c=$self->{c};
236 6 50       9 return unless exists $c->{$ctype};
237 6 100       25 return wantarray ? @{$c->{$ctype}} : $c->{$ctype}->[0];
  2         6  
238             }
239              
240             sub get_all
241             {
242 0     0 1 0 my ($self)=@_;
243 0         0 my %r=map { $_ => 1 } map { @{$_} } values(%{$self->{c}});
  0         0  
  0         0  
  0         0  
  0         0  
244 0         0 my @r = sort { $a cmp $b } keys %r;
  0         0  
245 0         0 return @r;
246             }
247              
248             sub match ## compare two contact lists
249             {
250 0     0 0 0 my ($self,$other)=@_;
251 0 0 0     0 return 0 unless (defined($other) && (ref($other) eq ref($self)));
252 0         0 my $c1=$self->{c};
253 0         0 my $c2=$other->{c};
254 0 0       0 return 0 unless (keys(%$c1)==keys(%$c2));
255 0 0       0 return 0 if grep { ! exists($c1->{$_}) } keys(%$c2);
  0         0  
256 0 0       0 return 0 if grep { ! exists($c2->{$_}) } keys(%$c1);
  0         0  
257 0         0 foreach my $k (sort { $a cmp $b } keys %$c1)
  0         0  
258             {
259 0         0 my %tmp1=map { $_->id() => 1 } @{$c1->{$k}};
  0         0  
  0         0  
260 0         0 my %tmp2=map { $_->id() => 1 } @{$c2->{$k}};
  0         0  
  0         0  
261 0 0       0 return 0 if grep { ! exists($tmp2{$_}) } keys(%tmp1);
  0         0  
262 0 0       0 return 0 if grep { ! exists($tmp1{$_}) } keys(%tmp2);
  0         0  
263             }
264              
265 0         0 return 1;
266             }
267              
268             sub has_contact
269             {
270 0     0 0 0 my ($self,$cobj,$ctype)=@_;
271 0 0       0 return 0 unless defined($cobj);
272 0         0 my $c=$self->{c};
273 0 0 0     0 return 0 if (defined($ctype) && !exists($c->{$ctype}));
274 0 0       0 my $id=(ref($cobj))? $cobj->id() : $cobj;
275 0 0 0     0 return 0 unless (defined($id) && $id);
276 0         0 foreach my $k (sort { $a cmp $b } keys %$c)
  0         0  
277             {
278 0 0 0     0 next if (defined($ctype) && ($k ne $ctype));
279 0 0       0 return 1 if defined($self->_pos($k,$id));
280             }
281 0         0 return 0;
282             }
283              
284             sub AUTOLOAD
285             {
286 5     5   747 my $self=shift;
287 5         7 my $attr=$AUTOLOAD;
288 5         23 $attr=~s/.*:://;
289 5 50       16 return unless $attr=~m/[^A-Z]/; ## skip DESTROY and all-cap methods
290              
291 5         4 my $ctype;
292 5 50       19 Net::DRI::Exception::method_not_implemented($attr,__PACKAGE__) unless ($ctype)=($attr=~m/^contact_(\S+)$/);
293 5         13 return $self->get($ctype);
294             }
295              
296             ##############################################################################
297             1;