File Coverage

blib/lib/Net/DRI/Protocol/EPP/Extensions/TCI/Contact.pm
Criterion Covered Total %
statement 18 198 9.0
branch 0 104 0.0
condition 0 47 0.0
subroutine 6 19 31.5
pod 0 12 0.0
total 24 380 6.3


line stmt bran cond sub pod time code
1             ## Domain Registry Interface, .RU/.SU/.XN--P1AI EPP Contact Extension for Net::DRI
2             ##
3             ## Copyright (c) 2010-2011 Dmitry Belyavsky
4             ## 2011-2013 Patrick Mevzek . All rights reserved.
5             ##
6             ## This file is part of Net::DRI
7             ##
8             ## Net::DRI is free software; you can redistribute it and/or modify
9             ## it under the terms of the GNU General Public License as published by
10             ## the Free Software Foundation; either version 2 of the License, or
11             ## (at your option) any later version.
12             ##
13             ## See the LICENSE file that comes with this distribution for more details.
14             ####################################################################################################
15              
16             package Net::DRI::Protocol::EPP::Extensions::TCI::Contact;
17              
18 1     1   920 use strict;
  1         1  
  1         23  
19 1     1   3 use warnings;
  1         1  
  1         17  
20              
21 1     1   3 use Net::DRI::Exception;
  1         1  
  1         13  
22 1     1   2 use Net::DRI::Util;
  1         1  
  1         12  
23 1     1   3 use Net::DRI::Protocol::EPP::Util;
  1         1  
  1         18  
24 1     1   2 use Net::DRI::Protocol::EPP::Core::Contact;
  1         1  
  1         1744  
25              
26             ####################################################################################################
27              
28             sub register_commands
29             {
30 0     0 0   my ($class, $version) = @_;
31 0           my %tmp = (
32             create => [ \&create, \&create_parse ],
33             update => [ \&update, undef ],
34             info => [ \&info, \&info_parse ],
35             );
36              
37 0           return { 'contact' => \%tmp };
38             }
39              
40             ####################################################################################################
41              
42             sub build_command
43             {
44 0     0 0   my ($msg, $command, $contact) = @_;
45 0 0         my @contact = (ref($contact) eq 'ARRAY')? @$contact : ($contact);
46 0 0         my @c = map { Net::DRI::Util::isa_contact($_) ?
  0            
47             $_->srid() : $_ } @contact;
48              
49 0 0         Net::DRI::Exception->die(1,'protocol/EPP',2,'Contact id needed')
50             unless @c;
51 0           foreach my $n (@c)
52             {
53 0 0 0       Net::DRI::Exception->die(1, 'protocol/EPP', 2,
      0        
54             'Contact id needed') unless (defined($n) && $n && !ref($n));
55 0 0         Net::DRI::Exception->die(1, 'protocol/EPP', 10,
56             'Invalid contact id: ' . $n)
57             unless Net::DRI::Util::xml_is_token($n, 3, 32);
58             }
59              
60 0 0         my $tcommand = (ref($command)) ? $command->[0] : $command;
61 0           $msg->command([$command, 'contact:' . $tcommand,
62             sprintf('xmlns:contact="%s" xsi:schemaLocation="%s %s"',$msg->nsattrs('contact'))]);
63              
64 0           my @d = map { ['contact:id', $_] } @c;
  0            
65 0 0 0       if (($tcommand =~ m/^(?:info|transfer)$/) && ref($contact[0]) &&
      0        
66             Net::DRI::Util::isa_contact($contact[0]))
67             {
68 0           my $az = $contact[0]->auth();
69 0 0 0       if ($az && ref($az) && exists($az->{pw}))
      0        
70             {
71 0           push(@d, ['contact:authInfo', $az->{pw}]);
72             }
73             }
74              
75 0           return @d;
76             }
77              
78             ############ Query commands
79             sub info
80             {
81 0     0 0   my ($epp,$c)=@_;
82 0           my $mes=$epp->message();
83 0           my @d=build_command($mes,'info',$c);
84 0           $mes->command_body(\@d);
85 0           return;
86             }
87              
88             sub info_parse
89             {
90 0     0 0   my ($po, $otype, $oaction, $oname, $rinfo) = @_;
91 0           my $mes = $po->message();
92 0 0         return unless $mes->is_success();
93              
94 0           my $infdata = $mes->get_response('contact','infData');
95 0 0         return unless $infdata;
96              
97 0           my $contact=$po->create_local_object('contact');
98 0           my @s;
99              
100 0           foreach my $el (Net::DRI::Util::xml_list_children($infdata))
101             {
102 0           my ($name,$c)=@$el;
103 0 0         if ($name eq 'id')
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
104             {
105 0           $oname=$c->textContent();
106 0           $rinfo->{contact}->{$oname}->{action}='info';
107 0           $rinfo->{contact}->{$oname}->{exist}=1;
108 0           $rinfo->{contact}->{$oname}->{id}=$oname;
109 0           $contact->srid($oname);
110             } elsif ($name eq 'roid')
111             {
112 0           $contact->roid($c->textContent());
113 0           $rinfo->{contact}->{$oname}->{roid}=$contact->roid();
114             } elsif ($name eq 'status')
115             {
116 0           push @s,Net::DRI::Protocol::EPP::Util::parse_status($c);
117             } elsif ($name=~m/^(clID|crID|upID)$/)
118             {
119 0           $rinfo->{contact}->{$oname}->{$1}=$c->textContent();
120             } elsif ($name=~m/^(crDate|upDate|trDate)$/)
121             {
122 0           $rinfo->{contact}->{$oname}->{$1}=$po->parse_iso8601($c->textContent());
123             } elsif ($name eq 'person')
124             {
125 0           $contact->person(parse_contact_data($c));
126             } elsif ($name eq 'organization')
127             {
128 0           $contact->organization(parse_contact_data($c));
129             } elsif ($name eq 'verified')
130             {
131 0           $contact->verified(1);
132             } elsif ($name eq 'unverified')
133             {
134 0           $contact->unverified(1);
135             }
136             else
137             {
138 0           warn "Unspecified behaviour for tag $name"
139             }
140             }
141              
142 0           $rinfo->{contact}->{$oname}->{status}=$po->create_local_object('status')->add(@s);
143 0           $rinfo->{contact}->{$oname}->{self}=$contact;
144 0           return;
145             }
146              
147             sub parse_contact_data
148             {
149 0     0 0   my $element = shift;
150 0           my $result = {};
151              
152 0           foreach my $el (Net::DRI::Util::xml_list_children($element))
153             {
154 0           my ($name,$c)=@$el;
155 0 0 0       if (($name eq 'email') || ($name eq 'fax') || ($name eq 'voice') || ($name eq 'passport'))
    0 0        
    0 0        
    0 0        
      0        
      0        
156             {
157 0           push @{$result->{$name}}, $c->textContent();
  0            
158             }
159             elsif (($name eq 'taxpayerNumbers') || ($name eq 'birthday'))
160             {
161 0           $result->{$name} = $c->textContent();
162             }
163             elsif (($name eq 'intPostalInfo') || ($name eq 'locPostalInfo') || ($name eq 'legalInfo'))
164             {
165 0           $result->{$name} = parse_address_data($c);
166             }
167             elsif ($name eq 'disclose')
168             {
169 0           $result->{disclose} = parse_disclose($c);
170             }
171             else
172             {
173 0           warn "Unspecified behaviour for tag $name"
174             }
175             }
176 0           return $result;
177             }
178              
179             sub parse_disclose
180             {
181 0     0 0   my $c=shift;
182 0           my $flag=Net::DRI::Util::xml_parse_boolean($c->getAttribute('flag'));
183 0           my %tmp;
184 0           foreach my $el (Net::DRI::Util::xml_list_children($c))
185             {
186 0           my ($name,$n)=@$el;
187 0 0         if ($name=~m/^(intName|locName|birthday|passport|name|org|addr|intOrg|locOrg|intAddress|locAddress|legalAddress|taxpayerNumbers)$/)
    0          
188             {
189 0           my $t=$n->getAttribute('type');
190 0           $tmp{$1}=$flag;
191             } elsif ($name=~m/^(voice|fax|email)$/)
192             {
193 0           $tmp{$1}=$flag;
194             }
195             else
196             {
197 0           warn "Unspecified behaviour for tag $name";
198             }
199             }
200 0           return \%tmp;
201             }
202              
203             sub parse_address_data
204             {
205 0     0 0   my $element = shift;
206 0           my $result = {};
207 0           foreach my $el (Net::DRI::Util::xml_list_children($element))
208             {
209 0           my ($name,$c)=@$el;
210 0 0 0       if (($name eq 'name') || ($name eq 'org'))
    0          
211             {
212 0           $result->{$name} = $c->textContent();
213             }
214             elsif ($name eq 'address')
215             {
216 0           push @{$result->{$name}}, $c->textContent();
  0            
217             }
218             else
219             {
220 0           warn "Unspecified behaviour for tag $name"
221             }
222             }
223              
224 0           return $result;
225             }
226              
227             ############ Transform commands
228              
229             sub build_disclose
230             {
231 0     0 0   my $contact = shift;
232 0           my $d=$contact->disclose();
233 0 0 0       return () unless ($d && ref($d));
234 0           my %v=map { $_ => 1 } values(%$d);
  0            
235 0 0         return () unless (keys(%v)==1); ## 1 or 0 as values, not both at same time
236              
237 0           my @d;
238 0 0         push(@d, ['contact:intName']) if (exists($d->{intName}));
239 0 0         push(@d, ['contact:locName']) if (exists($d->{locName}));
240              
241 0 0         push(@d, ['contact:org']) if (exists($d->{org}));
242 0 0         push(@d, ['contact:addr']) if (exists($d->{addr}));
243 0 0         push(@d, ['contact:voice']) if (exists($d->{voice}));
244 0 0         push(@d, ['contact:fax']) if (exists($d->{fax}));
245 0 0         push(@d, ['contact:email']) if (exists($d->{email}));
246              
247 0           return ['contact:disclose',@d,{flag=>(keys(%v))[0]}];
248             }
249              
250             sub build_cdata
251             {
252 0     0 0   my ($contact, $v) = @_;
253 0           my (@post, @addr);
254 0           my @tmp;
255 0           my @d;
256              
257 0           my ($tag_top, $tag_title, $data);
258 0 0         if ($contact->person())
    0          
259             {
260 0           $tag_top = 'person';
261 0           $tag_title = 'name';
262 0           $data = $contact->person();
263             }
264             elsif ($contact->organization())
265             {
266 0           $tag_top = 'organization';
267 0           $tag_title = 'org';
268 0           $data = $contact->organization();
269             }
270              
271 0           my @contact_data;
272 0           push @contact_data, ['contact:intPostalInfo' , _make_postal_info($data->{intPostalInfo}, $tag_title)];
273 0           push @contact_data, ['contact:locPostalInfo' , _make_postal_info($data->{locPostalInfo}, $tag_title)];
274              
275 0 0         if ($contact->organization())
276             {
277 0           push @contact_data, ['contact:legalInfo' , _make_postal_info($data->{legalInfo}, $tag_title )];
278             }
279              
280 0           push @contact_data, ['contact:taxpayerNumbers', $data->{taxpayerNumbers}];
281              
282 0 0         if ($contact->person())
283             {
284             #birthday
285 0           push @contact_data, ['contact:birthday', $data->{birthday}];
286              
287             #passport
288 0           for my $str (@{$data->{passport}})
  0            
289             {
290 0           push @contact_data, ['contact:passport', $str];
291             }
292             }
293              
294 0           for my $str (@{$data->{voice}})
  0            
295             {
296 0           push @contact_data, ['contact:voice', $str];
297             }
298              
299 0 0 0       if ($data->{fax} && scalar @{$data->{fax}})
  0            
300             {
301 0           for my $str (@{$data->{fax}})
  0            
302             {
303 0           push @contact_data, ['contact:fax', $str];
304             }
305             }
306             else
307             {
308 0           push @contact_data, ['contact:fax'];
309             }
310            
311 0           for my $str (@{$data->{email}})
  0            
312             {
313 0           push @contact_data, ['contact:email', $str];
314             }
315              
316 0           push(@contact_data, build_disclose($contact));
317              
318 0           push @d, ["contact:$tag_top", @contact_data];
319              
320 0 0         if ($contact->verified())
    0          
321             {
322 0           push @d, ['contact:verified'];
323             }
324             elsif ($contact->unverified())
325             {
326 0           push @d, ['contact:unverified'];
327             }
328              
329 0           return @d;
330             }
331              
332             sub _make_postal_info
333             {
334 0     0     my $data = shift;
335 0           my $tag = shift;
336              
337 0           my @d;
338            
339 0 0         push @d, ["contact:$tag", $data->{$tag}] if $data->{$tag};
340 0           for my $str (@{$data->{address}})
  0            
341             {
342 0           push @d, ['contact:address', $str];
343             }
344              
345 0           return @d;
346             }
347              
348             sub create
349             {
350 0     0 0   my ($epp, $contact) = @_;
351 0           my $mes = $epp->message();
352 0           my @d = build_command($mes, 'create', $contact);
353              
354 0 0         Net::DRI::Exception->die(1, 'protocol/EPP', 10, 'Invalid contact ' .
355             $contact) unless Net::DRI::Util::isa_contact($contact);
356 0           $contact->validate(); ## will trigger an Exception if needed
357 0           push(@d, build_cdata($contact, $epp->{contacti18n}));
358 0           $mes->command_body(\@d);
359 0           return;
360             }
361              
362             sub create_parse
363             {
364 0     0 0   my (@args)=@_;
365 0           return Net::DRI::Protocol::EPP::Core::Contact::create_parse(@args);
366             }
367              
368             sub update
369             {
370 0     0 0   my ($epp, $contact, $todo) = @_;
371 0           my $mes = $epp->message();
372              
373 0 0         Net::DRI::Exception::usererr_invalid_parameters($todo .
374             ' must be a Net::DRI::Data::Changes object')
375             unless Net::DRI::Util::isa_changes($todo);
376 0 0 0       if ((grep { ! /^(?:add|del)$/ } $todo->types('status')) ||
  0            
377 0           (grep { ! /^(?:set)$/ } $todo->types('info')))
378             {
379 0           Net::DRI::Exception->die(0, 'protocol/EPP', 11,
380             'Only status add/del or info set available for ' .
381             'contact');
382             }
383              
384 0           my @d = build_command($mes, 'update', $contact);
385              
386 0           my $sadd = $todo->add('status');
387 0           my $sdel = $todo->del('status');
388 0 0         push(@d, ['contact:add', $sadd->build_xml('contact:status')])
389             if ($sadd);
390 0 0         push(@d, ['contact:rem', $sdel->build_xml('contact:status')])
391             if ($sdel);
392              
393 0           my $newc = $todo->set('info');
394 0 0         if ($newc)
395             {
396 0 0         Net::DRI::Exception->die(1, 'protocol/EPP', 10,
397             'Invalid contact ' . $newc)
398             unless Net::DRI::Util::isa_contact($newc);
399 0           $newc->validate(1); ## will trigger an Exception if needed
400 0           my @c = build_cdata($newc, $epp->{contacti18n});
401 0 0         push(@d, ['contact:chg', @c]) if (@c);
402             }
403              
404 0           $mes->command_body(\@d);
405 0           return;
406             }
407              
408             ####################################################################################################
409             1;
410              
411             =pod
412              
413             =head1 NAME
414              
415             Net::DRI::Protocol::EPP::Extensions::TCI::Contact - TCI EPP Contact Extension for Net::DRI
416              
417             =head1 DESCRIPTION
418              
419             Please see the README file for details.
420              
421             =head1 SUPPORT
422              
423             For now, support questions should be sent to:
424              
425             Enetdri@dotandco.comE
426              
427             Please also see the SUPPORT file in the distribution.
428              
429             =head1 SEE ALSO
430              
431             Ehttp://www.dotandco.com/services/software/Net-DRI/E
432              
433             =head1 AUTHOR
434              
435             Dmitry Belyavsky, Ebeldmit@gmail.comE
436             Patrick Mevzek, Enetdri@dotandco.comE
437              
438             =head1 COPYRIGHT
439              
440             Copyright (c) 2010-2011 Dmitry Belyavsky
441             Copyright (c) 2011-2013 Patrick Mevzek .
442             All rights reserved.
443              
444             This program is free software; you can redistribute it and/or modify
445             it under the terms of the GNU General Public License as published by
446             the Free Software Foundation; either version 2 of the License, or
447             (at your option) any later version.
448              
449             See the LICENSE file that comes with this distribution for more details.
450              
451             =cut