File Coverage

blib/lib/Net/DRI/Protocol/EPP/Core/Domain.pm
Criterion Covered Total %
statement 18 226 7.9
branch 0 142 0.0
condition 0 33 0.0
subroutine 6 23 26.0
pod 0 17 0.0
total 24 441 5.4


line stmt bran cond sub pod time code
1             ## Domain Registry Interface, EPP Domain commands (RFC5731)
2             ##
3             ## Copyright (c) 2005-2010,2012-2015 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::Protocol::EPP::Core::Domain;
16              
17 1     1   1210 use utf8;
  1         1  
  1         10  
18 1     1   29 use strict;
  1         2  
  1         33  
19 1     1   5 use warnings;
  1         1  
  1         27  
20              
21 1     1   4 use Net::DRI::Util;
  1         1  
  1         16  
22 1     1   4 use Net::DRI::Exception;
  1         1  
  1         16  
23 1     1   9 use Net::DRI::Protocol::EPP::Util;
  1         1  
  1         2849  
24              
25             =pod
26              
27             =head1 NAME
28              
29             Net::DRI::Protocol::EPP::Core::Domain - EPP Domain commands (RFC5731) for Net::DRI
30              
31             =head1 DESCRIPTION
32              
33             Please see the README file for details.
34              
35             =head1 SUPPORT
36              
37             For now, support questions should be sent to:
38              
39             Enetdri@dotandco.comE
40              
41             Please also see the SUPPORT file in the distribution.
42              
43             =head1 SEE ALSO
44              
45             Ehttp://www.dotandco.com/services/software/Net-DRI/E
46              
47             =head1 AUTHOR
48              
49             Patrick Mevzek, Enetdri@dotandco.comE
50              
51             =head1 COPYRIGHT
52              
53             Copyright (c) 2005-2010,2012-2015 Patrick Mevzek .
54             All rights reserved.
55              
56             This program is free software; you can redistribute it and/or modify
57             it under the terms of the GNU General Public License as published by
58             the Free Software Foundation; either version 2 of the License, or
59             (at your option) any later version.
60              
61             See the LICENSE file that comes with this distribution for more details.
62              
63             =cut
64              
65             ####################################################################################################
66              
67             sub register_commands
68             {
69 0     0 0   my ($class,$version)=@_;
70 0           my %tmp=(
71             check => [ \&check, \&check_parse ],
72             info => [ \&info, \&info_parse ],
73             transfer_query => [ \&transfer_query, \&transfer_parse ],
74             create => [ \&create, \&create_parse ],
75             delete => [ \&delete ],
76             renew => [ \&renew, \&renew_parse ],
77             transfer_request => [ \&transfer_request, \&transfer_parse ],
78             transfer_cancel => [ \&transfer_cancel,\&transfer_parse ],
79             transfer_answer => [ \&transfer_answer,\&transfer_parse ],
80             update => [ \&update ],
81             review_complete => [ undef, \&pandata_parse ],
82             );
83              
84 0           $tmp{check_multi}=$tmp{check};
85 0           return { 'domain' => \%tmp };
86             }
87              
88             ####################################################################################################
89             ########### Query commands
90              
91             sub check
92             {
93 0     0 0   my ($epp,$domain,$rd)=@_;
94 0           my $mes=$epp->message();
95 0           my @d=Net::DRI::Protocol::EPP::Util::domain_build_command($mes,'check',$domain);
96 0           $mes->command_body(\@d);
97 0           return;
98             }
99              
100             sub check_parse
101             {
102 0     0 0   my ($po,$otype,$oaction,$oname,$rinfo)=@_;
103 0           my $mes=$po->message();
104 0 0         return unless $mes->is_success();
105              
106 0           my $chkdata=$mes->get_response('domain','chkData');
107 0 0         return unless defined $chkdata;
108              
109 0           foreach my $cd ($chkdata->getChildrenByTagNameNS($mes->ns('domain'),'cd'))
110             {
111 0           my $domain;
112 0           foreach my $el (Net::DRI::Util::xml_list_children($cd))
113             {
114 0           my ($n,$c)=@$el;
115 0 0         if ($n eq 'name')
    0          
116             {
117 0           $domain=lc($c->textContent());
118 0           $rinfo->{domain}->{$domain}->{action}='check';
119 0           $rinfo->{domain}->{$domain}->{exist}=1-Net::DRI::Util::xml_parse_boolean($c->getAttribute('avail'));
120             } elsif ($n eq 'reason')
121             {
122 0           $rinfo->{domain}->{$domain}->{exist_reason}=$c->textContent();
123             }
124             }
125             }
126 0           return;
127             }
128              
129             sub info
130             {
131 0     0 0   my ($epp,$domain,$rd)=@_;
132 0           my $mes=$epp->message();
133 0 0 0       my $hosts=(defined $rd && ref $rd eq 'HASH' && exists $rd->{hosts} && $rd->{hosts}=~m/^(?:all|del|sub|none)$/)? $rd->{hosts} : 'all';
134 0           my @d=Net::DRI::Protocol::EPP::Util::domain_build_command($mes,'info',$domain,{'hosts'=> $hosts});
135 0 0         push @d,Net::DRI::Protocol::EPP::Util::domain_build_authinfo($epp,$rd->{auth}) if Net::DRI::Util::has_auth($rd);
136 0           $mes->command_body(\@d);
137 0           return;
138             }
139              
140             sub info_parse
141             {
142 0     0 0   my ($po,$otype,$oaction,$oname,$rinfo)=@_;
143 0           my $mes=$po->message();
144 0 0         return unless $mes->is_success();
145 0           my $infdata=$mes->get_response('domain','infData');
146 0 0         return unless defined $infdata;
147              
148 0           my (@s,@host);
149 0           my $cs=$po->create_local_object('contactset');
150 0           my %ccache;
151 0           foreach my $el (Net::DRI::Util::xml_list_children($infdata))
152             {
153 0           my ($name,$c)=@$el;
154 0 0         if ($name eq 'name')
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
155             {
156 0           $oname=lc($c->textContent());
157 0           $rinfo->{domain}->{$oname}->{action}='info';
158 0           $rinfo->{domain}->{$oname}->{exist}=1;
159             } elsif ($name eq 'roid')
160             {
161 0           $rinfo->{domain}->{$oname}->{roid}=$c->textContent();
162             } elsif ($name eq 'status')
163             {
164 0           push @s,Net::DRI::Protocol::EPP::Util::parse_node_status($c);
165             } elsif ($name eq 'registrant')
166             {
167 0           my $id=$c->textContent();
168 0 0         $ccache{$id}=$po->create_local_object('contact')->srid($id) unless exists $ccache{$id};
169 0           $cs->set($ccache{$id},'registrant');
170             } elsif ($name eq 'contact')
171             {
172 0           my $id=$c->textContent();
173 0 0         $ccache{$id}=$po->create_local_object('contact')->srid($id) unless exists $ccache{$id};
174 0           $cs->add($ccache{$id},$c->getAttribute('type'));
175             } elsif ($name eq 'ns')
176             {
177 0           $rinfo->{domain}->{$oname}->{ns}=Net::DRI::Protocol::EPP::Util::parse_ns($po,$c);
178             } elsif ($name eq 'host')
179             {
180 0           push @host,$c->textContent();
181             } elsif ($name=~m/^(clID|crID|upID)$/)
182             {
183 0           $rinfo->{domain}->{$oname}->{$1}=$c->textContent();
184             } elsif ($name=~m/^(crDate|upDate|trDate|exDate)$/)
185             {
186 0           $rinfo->{domain}->{$oname}->{$1}=$po->parse_iso8601($c->textContent());
187             } elsif ($name eq 'authInfo') ## we only try to parse the authInfo version defined in the RFC, other cases are to be handled by extensions
188             {
189 0           $rinfo->{domain}->{$oname}->{auth}={pw => Net::DRI::Util::xml_child_content($c,$mes->ns('domain'),'pw')};
190             }
191             }
192              
193 0           $rinfo->{domain}->{$oname}->{contact}=$cs;
194 0           $rinfo->{domain}->{$oname}->{status}=$po->create_local_object('status')->add(@s);
195 0 0         $rinfo->{domain}->{$oname}->{subordinate_hosts}=$po->create_local_object('hosts')->set(@host) if @host;
196 0           return;
197             }
198              
199             sub transfer_query
200             {
201 0     0 0   my ($epp,$domain,$rd)=@_;
202 0           my $mes=$epp->message();
203 0           my @d=Net::DRI::Protocol::EPP::Util::domain_build_command($mes,['transfer',{'op'=>'query'}],$domain);
204 0 0         push @d,Net::DRI::Protocol::EPP::Util::domain_build_authinfo($epp,$rd->{auth}) if Net::DRI::Util::has_auth($rd);
205 0           $mes->command_body(\@d);
206 0           return;
207             }
208              
209             sub transfer_parse
210             {
211 0     0 0   my ($po,$otype,$oaction,$oname,$rinfo)=@_;
212 0           my $mes=$po->message();
213 0 0         return unless $mes->is_success();
214              
215 0           my $trndata=$mes->get_response('domain','trnData');
216 0 0         return unless defined $trndata;
217              
218 0           foreach my $el (Net::DRI::Util::xml_list_children($trndata))
219             {
220 0           my ($name,$c)=@$el;
221 0 0         if ($name eq 'name')
    0          
    0          
222             {
223 0           $oname=lc($c->textContent());
224 0           $rinfo->{domain}->{$oname}->{action}='transfer';
225 0           $rinfo->{domain}->{$oname}->{exist}=1;
226             } elsif ($name=~m/^(trStatus|reID|acID)$/)
227             {
228 0           $rinfo->{domain}->{$oname}->{$1}=$c->textContent();
229             } elsif ($name=~m/^(reDate|acDate|exDate)$/)
230             {
231 0           $rinfo->{domain}->{$oname}->{$1}=$po->parse_iso8601($c->textContent());
232             }
233             }
234 0           return;
235             }
236              
237             ############ Transform commands
238              
239             sub create
240             {
241 0     0 0   my ($epp,$domain,$rd)=@_;
242 0           my $mes=$epp->message();
243 0           my @d=Net::DRI::Protocol::EPP::Util::domain_build_command($mes,'create',$domain);
244              
245 0           my $def=$epp->default_parameters();
246 0 0 0       if ($def && (ref($def) eq 'HASH') && exists($def->{domain_create}) && (ref($def->{domain_create}) eq 'HASH'))
      0        
      0        
247             {
248 0 0 0       $rd={} unless ($rd && ref $rd eq 'HASH' && keys %$rd);
      0        
249 0           while(my ($k,$v)=each(%{$def->{domain_create}}))
  0            
250             {
251 0 0         next if exists($rd->{$k});
252 0           $rd->{$k}=$v;
253             }
254             }
255              
256             ## Period, OPTIONAL
257 0 0         push @d,Net::DRI::Protocol::EPP::Util::build_period($rd->{duration}) if Net::DRI::Util::has_duration($rd);
258              
259             ## Nameservers, OPTIONAL
260 0 0         push @d,Net::DRI::Protocol::EPP::Util::build_ns($epp,$rd->{ns},$domain) if Net::DRI::Util::has_ns($rd);
261              
262             ## Contacts, all OPTIONAL
263 0 0         if (Net::DRI::Util::has_contact($rd))
264             {
265 0           my $cs=$rd->{contact};
266 0           my @o=$cs->get('registrant');
267 0 0 0       push @d,['domain:registrant',$o[0]->srid()] if (@o && Net::DRI::Util::isa_contact($o[0]));
268 0           push @d,Net::DRI::Protocol::EPP::Util::build_core_contacts($epp,$cs);
269             }
270              
271             ## AuthInfo
272 0 0         Net::DRI::Exception::usererr_insufficient_parameters('authInfo is mandatory') unless Net::DRI::Util::has_auth($rd);
273 0           push @d,Net::DRI::Protocol::EPP::Util::domain_build_authinfo($epp,$rd->{auth});
274 0           $mes->command_body(\@d);
275 0           return;
276             }
277              
278             sub create_parse
279             {
280 0     0 0   my ($po,$otype,$oaction,$oname,$rinfo)=@_;
281 0           my $mes=$po->message();
282 0 0         return unless $mes->is_success();
283              
284 0           my $credata=$mes->get_response('domain','creData');
285 0 0         return unless defined $credata;
286              
287 0           foreach my $el (Net::DRI::Util::xml_list_children($credata))
288             {
289 0           my ($name,$c)=@$el;
290 0 0         if ($name eq 'name')
    0          
291             {
292 0           $oname=lc($c->textContent());
293 0           $rinfo->{domain}->{$oname}->{action}='create';
294 0           $rinfo->{domain}->{$oname}->{exist}=1;
295             } elsif ($name=~m/^(crDate|exDate)$/)
296             {
297 0           $rinfo->{domain}->{$oname}->{$1}=$po->parse_iso8601($c->textContent());
298             }
299             }
300 0           return;
301             }
302              
303             sub delete ## no critic (Subroutines::ProhibitBuiltinHomonyms)
304             {
305 0     0 0   my ($epp,$domain,$rd)=@_;
306 0           my $mes=$epp->message();
307 0           my @d=Net::DRI::Protocol::EPP::Util::domain_build_command($mes,'delete',$domain);
308 0           $mes->command_body(\@d);
309 0           return;
310             }
311              
312             sub renew
313             {
314 0     0 0   my ($epp,$domain,$rd)=@_;
315 0 0         my $curexp=Net::DRI::Util::has_key($rd,'current_expiration')? $rd->{current_expiration} : undef;
316 0 0         Net::DRI::Exception::usererr_insufficient_parameters('current expiration date') unless defined($curexp);
317 0 0 0       $curexp=$curexp->clone()->set_time_zone('UTC')->strftime('%Y-%m-%d') if (ref($curexp) && Net::DRI::Util::check_isa($curexp,'DateTime'));
318 0 0         Net::DRI::Exception::usererr_invalid_parameters('current expiration date must be YYYY-MM-DD') unless $curexp=~m/^\d{4}-\d{2}-\d{2}$/;
319              
320 0           my $mes=$epp->message();
321 0           my @d=Net::DRI::Protocol::EPP::Util::domain_build_command($mes,'renew',$domain);
322 0           push @d,['domain:curExpDate',$curexp];
323 0 0         push @d,Net::DRI::Protocol::EPP::Util::build_period($rd->{duration}) if Net::DRI::Util::has_duration($rd);
324              
325 0           $mes->command_body(\@d);
326 0           return;
327             }
328              
329             sub renew_parse
330             {
331 0     0 0   my ($po,$otype,$oaction,$oname,$rinfo)=@_;
332 0           my $mes=$po->message();
333 0 0         return unless $mes->is_success();
334              
335 0           my $rendata=$mes->get_response('domain','renData');
336 0 0         return unless defined $rendata;
337              
338 0           foreach my $el (Net::DRI::Util::xml_list_children($rendata))
339             {
340 0           my ($name,$c)=@$el;
341 0 0         if ($name eq 'name')
    0          
342             {
343 0           $oname=lc($c->textContent());
344 0           $rinfo->{domain}->{$oname}->{action}='renew';
345 0           $rinfo->{domain}->{$oname}->{exist}=1;
346             } elsif ($name=~m/^(exDate)$/)
347             {
348 0           $rinfo->{domain}->{$oname}->{$1}=$po->parse_iso8601($c->textContent());
349             }
350             }
351 0           return;
352             }
353              
354             sub transfer_request
355             {
356 0     0 0   my ($epp,$domain,$rd)=@_;
357 0           my $mes=$epp->message();
358 0           my @d=Net::DRI::Protocol::EPP::Util::domain_build_command($mes,['transfer',{'op'=>'request'}],$domain);
359 0 0         push @d,Net::DRI::Protocol::EPP::Util::build_period($rd->{duration}) if Net::DRI::Util::has_duration($rd);
360 0 0         push @d,Net::DRI::Protocol::EPP::Util::domain_build_authinfo($epp,$rd->{auth}) if Net::DRI::Util::has_auth($rd);
361 0           $mes->command_body(\@d);
362 0           return;
363             }
364              
365             sub transfer_answer
366             {
367 0     0 0   my ($epp,$domain,$rd)=@_;
368 0           my $mes=$epp->message();
369 0 0 0       my @d=Net::DRI::Protocol::EPP::Util::domain_build_command($mes,['transfer',{'op'=>(Net::DRI::Util::has_key($rd,'approve') && $rd->{approve})? 'approve' : 'reject'}],$domain);
370 0 0         push @d,Net::DRI::Protocol::EPP::Util::domain_build_authinfo($epp,$rd->{auth}) if Net::DRI::Util::has_auth($rd);
371 0           $mes->command_body(\@d);
372 0           return;
373             }
374              
375             sub transfer_cancel
376             {
377 0     0 0   my ($epp,$domain,$rd)=@_;
378 0           my $mes=$epp->message();
379 0           my @d=Net::DRI::Protocol::EPP::Util::domain_build_command($mes,['transfer',{'op'=>'cancel'}],$domain);
380 0 0         push @d,Net::DRI::Protocol::EPP::Util::domain_build_authinfo($epp,$rd->{auth}) if Net::DRI::Util::has_auth($rd);
381 0           $mes->command_body(\@d);
382 0           return;
383             }
384              
385             sub update
386             {
387 0     0 0   my ($epp,$domain,$todo)=@_;
388 0           my $mes=$epp->message();
389              
390 0 0         Net::DRI::Exception::usererr_invalid_parameters($todo.' must be a non empty Net::DRI::Data::Changes object') unless Net::DRI::Util::isa_changes($todo);
391              
392 0           my $nsadd=$todo->add('ns');
393 0           my $nsdel=$todo->del('ns');
394 0           my $sadd=$todo->add('status');
395 0           my $sdel=$todo->del('status');
396 0           my $cadd=$todo->add('contact');
397 0           my $cdel=$todo->del('contact');
398              
399 0           my (@add,@del);
400 0 0         push @add,Net::DRI::Protocol::EPP::Util::build_ns($epp,$nsadd,$domain) if Net::DRI::Util::isa_hosts($nsadd);
401 0 0         push @add,Net::DRI::Protocol::EPP::Util::build_core_contacts($epp,$cadd) if Net::DRI::Util::isa_contactset($cadd);
402 0 0         push @add,$sadd->build_xml('domain:status','core') if Net::DRI::Util::isa_statuslist($sadd);
403 0 0         push @del,Net::DRI::Protocol::EPP::Util::build_ns($epp,$nsdel,$domain,undef,1) if Net::DRI::Util::isa_hosts($nsdel);
404 0 0         push @del,Net::DRI::Protocol::EPP::Util::build_core_contacts($epp,$cdel) if Net::DRI::Util::isa_contactset($cdel);
405 0 0         push @del,$sdel->build_xml('domain:status','core') if Net::DRI::Util::isa_statuslist($sdel);
406              
407 0           my @d=Net::DRI::Protocol::EPP::Util::domain_build_command($mes,'update',$domain);
408 0 0         push @d,['domain:add',@add] if @add;
409 0 0         push @d,['domain:rem',@del] if @del;
410              
411 0           my $chg=$todo->set('registrant');
412 0           my @chg;
413 0 0         push @chg,['domain:registrant',$chg->srid()] if Net::DRI::Util::isa_contact($chg);
414 0           $chg=$todo->set('auth');
415 0 0 0       push @chg,Net::DRI::Protocol::EPP::Util::domain_build_authinfo($epp,$chg,1) if ($chg && (ref $chg eq 'HASH') && exists $chg->{pw});
      0        
416 0 0         push @d,['domain:chg',@chg] if @chg;
417 0           $mes->command_body(\@d);
418 0           return;
419             }
420              
421             ####################################################################################################
422             ## RFC4931 ยง3.3 Offline Review of Requested Actions
423              
424             sub pandata_parse
425             {
426 0     0 0   my ($po,$otype,$oaction,$oname,$rinfo)=@_;
427 0           my $mes=$po->message();
428 0 0         return unless $mes->is_success();
429              
430 0           my $pandata=$mes->get_response('domain','panData');
431 0 0         return unless defined $pandata;
432              
433 0           foreach my $el (Net::DRI::Util::xml_list_children($pandata))
434             {
435 0           my ($name,$c)=@$el;
436 0 0         if ($name eq 'name')
    0          
    0          
437             {
438 0           $oname=lc($c->textContent());
439 0           $rinfo->{domain}->{$oname}->{action}='review';
440 0           $rinfo->{domain}->{$oname}->{result}=Net::DRI::Util::xml_parse_boolean($c->getAttribute('paResult'));
441             } elsif ($name eq 'paTRID')
442             {
443 0           my $ns=$mes->ns('_main');
444 0           my $tmp=Net::DRI::Util::xml_child_content($c,$ns,'clTRID');
445 0 0         $rinfo->{domain}->{$oname}->{trid}=$tmp if defined $tmp;
446 0           $rinfo->{domain}->{$oname}->{svtrid}=Net::DRI::Util::xml_child_content($c,$ns,'svTRID');
447             } elsif ($name eq 'paDate')
448             {
449 0           $rinfo->{domain}->{$oname}->{date}=$po->parse_iso8601($c->textContent());
450             }
451             }
452 0           return;
453             }
454              
455             ####################################################################################################
456             1;