File Coverage

blib/lib/Net/DRI/Protocol/EPP/Extensions/Nominet/Domain.pm
Criterion Covered Total %
statement 18 143 12.5
branch 0 78 0.0
condition 0 27 0.0
subroutine 6 19 31.5
pod 0 13 0.0
total 24 280 8.5


line stmt bran cond sub pod time code
1             ## Domain Registry Interface, .UK EPP Domain commands
2             ##
3             ## Copyright (c) 2008-2010,2013-2014 Patrick Mevzek . All rights reserved.
4             ## (c) 2013 Michael Holloway . 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::Nominet::Domain;
17              
18 1     1   1085 use strict;
  1         2  
  1         29  
19 1     1   5 use warnings;
  1         1  
  1         20  
20              
21 1     1   4 use Net::DRI::Util;
  1         1  
  1         15  
22 1     1   3 use Net::DRI::Exception;
  1         2  
  1         20  
23 1     1   4 use Net::DRI::Protocol::EPP::Util;
  1         2  
  1         16  
24 1     1   4 use Net::DRI::Protocol::EPP::Core::Domain;
  1         1  
  1         1567  
25              
26             =pod
27              
28             =head1 NAME
29              
30             Net::DRI::Protocol::EPP::Extensions::Nominet::Domain - .UK EPP Domain commands for Net::DRI
31              
32             =head1 DESCRIPTION
33              
34             Please see the README file for details.
35              
36             =head1 SUPPORT
37              
38             For now, support questions should be sent to:
39              
40             Enetdri@dotandco.comE
41              
42             Please also see the SUPPORT file in the distribution.
43              
44             =head1 SEE ALSO
45              
46             Ehttp://www.dotandco.com/services/software/Net-DRI/E
47              
48             =head1 AUTHOR
49              
50             Patrick Mevzek, Enetdri@dotandco.comE
51              
52             =head1 COPYRIGHT
53              
54             Copyright (c) 2008-2010,2013-2014 Patrick Mevzek .
55             (c) 2013 Michael Holloway .
56             All rights reserved.
57              
58             This program is free software; you can redistribute it and/or modify
59             it under the terms of the GNU General Public License as published by
60             the Free Software Foundation; either version 2 of the License, or
61             (at your option) any later version.
62              
63             See the LICENSE file that comes with this distribution for more details.
64              
65             =cut
66              
67             ####################################################################################################
68             sub register_commands
69             {
70 0     0 0   my ($class,$version)=@_;
71 0           my %tmp=(
72             info => [ undef, \&info_parse ],
73             create => [ \&create ],
74             update => [\&update],
75             unrenew => [\&unrenew, \&Net::DRI::Protocol::EPP::Core::Domain::renew_parse ],
76             list => [\&list, \&list_parse ],
77             lock => [\&lock],
78             transfer_start => [\&release],
79             transfer_accept => [\&handshake_accept, \&handshake_parse],
80             transfer_refuse => [\&handshake_reject],
81             );
82 0           return { 'domain' => \%tmp };
83             }
84              
85             ####################################################################################################
86             ########### Query commands
87              
88              
89             sub info_parse
90             {
91 0     0 0   my ($po,$otype,$oaction,$oname,$rinfo)=@_;
92 0           my $mes=$po->message();
93 0 0         return unless $mes->is_success();
94              
95 0           my $infdata=$mes->get_extension('domain-nom-ext','infData');
96 0 0         return unless $infdata;
97              
98 0           foreach my $el (Net::DRI::Util::xml_list_children($infdata))
99             {
100 0           my ($name,$c)=@$el;
101 0 0         next unless $name =~ m/^(reg-status|first-bill|recur-bill|auto-bill|next-bill|auto-period|next-period|notes|reseller|renew-not-required)$/;
102 0           $rinfo->{domain}->{$oname}->{$name} = $c->textContent();
103             }
104 0           return;
105             }
106              
107             sub list_parse
108             {
109 0     0 0   my ($po,$otype,$oaction,$oname,$rinfo)=@_;
110 0           my $mes=$po->message();
111 0 0         return unless $mes->is_success();
112 0           my $infdata=$mes->get_response('std-list','listData');
113 0 0         return unless $infdata;
114 0           $rinfo->{domain_list}->{0}->{total} = $infdata->getAttribute('noDomains');
115 0           foreach my $el (Net::DRI::Util::xml_list_children($infdata))
116             {
117 0           my ($name,$c)=@$el;
118 0 0         push @{$rinfo->{domain_list}->{0}->{domains}}, $c->textContent() if $name eq 'domainName';
  0            
119             }
120 0           return;
121             }
122              
123             sub handshake_parse
124             {
125 0     0 0   my ($po,$otype,$oaction,$oname,$rinfo)=@_;
126 0           my $mes=$po->message();
127 0 0         return unless $mes->is_success();
128 0 0         return unless my $infdata=$mes->get_response('std-handshake','hanData');
129 0           my $ns = $mes->ns('std-handshake');
130 0 0         return unless my $dl = $infdata->getChildrenByTagNameNS($ns,'domainListData')->shift();
131 0           $rinfo->{domain_list}->{0}->{total} = $dl->getAttribute('noDomains');
132 0           foreach my $el (Net::DRI::Util::xml_list_children($dl))
133             {
134 0           my ($name,$c)=@$el;
135 0 0         push @{$rinfo->{domain_list}->{0}->{domains}}, $c->textContent() if $name eq 'domainName';
  0            
136             }
137 0           return;
138             }
139              
140             ############ Transform commands ####################################################################
141              
142             sub domain_nom_ext
143             {
144 0     0 0   my $rd=shift;
145 0           my @n;
146             #TODO Validate these fields?
147             my @errs;
148 0 0 0       foreach (qw/first-bill recur-bill/) { push @errs, "$_ [$rd->{$_}]" if ($rd->{$_} && $rd->{$_} !~ m/^(bc|th)$/); }
  0            
149 0 0 0       foreach (qw/auto-bill next-bill/) { push @errs, "$_ [$rd->{$_}]" if ($rd->{$_} && !($rd->{$_} =~ /^[+]?\d+$/ && $rd->{$_}<183)); }
  0   0        
150 0 0 0       foreach (qw/auto-period next-period/) { push @errs, "$_ [$rd->{$_}]" if ($rd->{$_} && !($rd->{$_} =~ /^[+]?\d+$/ && $rd->{$_}<10)); }
  0   0        
151 0           foreach (qw/renew-not-required/)
152             {
153 0 0         next unless $rd->{$_};
154 0 0         $rd->{$_} = 'Y' if $rd->{$_} =~ m/^(1|Y|YES|TRUE)$/i;
155 0 0         $rd->{$_} = 'N' if $rd->{$_} =~ m/^(0|N|NO|FALSE)$/i;
156 0 0         push @errs, "$_ [$rd->{$_}]" if $rd->{$_} !~ m/^(Y|N)$/;
157             }
158 0 0         Net::DRI::Exception::usererr_invalid_parameters('Invalid domain information: '.join('/',@errs)) if @errs;
159              
160 0           foreach (qw/first-bill recur-bill auto-bill next-bill notes reseller auto-period next-period renew-not-required/) {
161 0           my $f = $_;
162 0 0         push @n, ['domain-nom-ext:'.$f, $rd->{$_}] if defined $rd->{$_};
163             }
164 0           return @n;
165             }
166              
167             sub create {
168 0     0 0   my ($epp,$domain,$rd)=@_;
169 0           undef $rd->{'renew-not-required'}; # only for updates
170 0           my @n = domain_nom_ext($rd);
171 0 0         return unless @n;
172 0           my $mes=$epp->message();
173 0           my $eid=$mes->command_extension_register('domain-nom-ext:create',sprintf('xmlns:domain-nom-ext="%s" xsi:schemaLocation="%s %s"',$mes->nsattrs('domain-nom-ext')));
174 0           $mes->command_extension($eid,\@n);
175 0           return;
176             }
177              
178             sub update {
179 0     0 0   my ($epp,$domain,$todo)=@_;
180 0           my $rd;
181 0           foreach (qw/first-bill recur-bill auto-bill next-bill notes reseller auto-period next-period renew-not-required/) {
182 0 0         $rd->{$_} = $todo->set($_) if defined $todo->set($_);
183             }
184 0 0         return unless $rd;
185 0           my @n = domain_nom_ext($rd);
186 0 0         return unless @n;
187 0           my $mes=$epp->message();
188 0           my $eid=$mes->command_extension_register('domain-nom-ext:update',sprintf('xmlns:domain-nom-ext="%s" xsi:schemaLocation="%s %s"',$mes->nsattrs('domain-nom-ext')));
189 0           $mes->command_extension($eid,\@n);
190 0           return;
191             }
192              
193             sub list
194             {
195 0     0 0   my ($epp,$rd)=@_;
196 0           my $mes=$epp->message();
197 0 0 0       Net::DRI::Exception::usererr_insufficient_parameters('month or expiry is required') unless $rd->{regMonth} || $rd->{exMonth};
198 0           foreach (qw/regMonth exMonth/)
199             {
200 0 0         $rd->{$_} = $rd->{$_}->format_cldr('yyyy-MM') if UNIVERSAL::isa($rd->{$_},'DateTime');
201 0 0 0       Net::DRI::Exception::usererr_invalid_parameters($_) if $rd->{$_} and $rd->{$_} !~ m/^[0-9]{4}-[0-9]{2}$/;
202             }
203              
204 0           $mes->command(['info','l:list',sprintf('xmlns:l="%s" xsi:schemaLocation="%s %s"',$mes->nsattrs('std-list'))]);
205 0           my @d;
206 0 0         push @d, ['l:month',$rd->{'regMonth'}] if $rd->{regMonth};
207 0 0         push @d, ['l:expiry',$rd->{'exMonth'}] if $rd->{exMonth};
208 0           $mes->command_body(\@d);
209 0           return;
210             }
211              
212             ## Warning: this can also be used for multiple domain names at once,
213             ## see http://www.nominet.org.uk/registrars/systems/nominetepp/Unrenew/
214             ## However, if we accept that, we will probably have to tweak Core::Domain::renew_parse
215             ## to handle multiple renData nodes in the response.
216             sub unrenew
217             {
218 0     0 0   my ($epp,$domain,$rd)=@_;
219 0           my $mes=$epp->message();
220 0 0         Net::DRI::Exception::usererr_insufficient_parameters('Domain name required') unless $domain;
221 0 0         Net::DRI::Exception::usererr_invalid_parameters('domain') unless Net::DRI::Util::is_hostname($domain);
222 0           $mes->command(['update','u:unrenew',sprintf('xmlns:u="%s" xsi:schemaLocation="%s %s"',$mes->nsattrs('std-unrenew'))]);
223 0           my @d=(['u:domainName',$domain]);
224 0           $mes->command_body(\@d);
225 0           return;
226             }
227              
228             # called by domain_transfer_start, can release a domain or an account here
229             sub release
230             {
231 0     0 0   my ($epp,$domain,$rd)=@_;
232 0           my $mes=$epp->message();
233 0 0         Net::DRI::Exception::usererr_insufficient_parameters('Domain name required, specify alldomains.co.uk if you are releasing an account') unless $domain;
234 0 0         Net::DRI::Exception::usererr_insufficient_parameters('registar_tag is required') unless $rd->{registrar_tag};
235 0 0 0       Net::DRI::Exception::usererr_insufficient_parameters('To release an account you must specify alldomains.co.uk as the domain name') if defined $rd->{account_id} && $domain ne 'alldomains.co.uk'; # failsafe
236 0           $mes->command(['update','r:release',sprintf('xmlns:r="%s" xsi:schemaLocation="%s %s"',$mes->nsattrs('std-release'))]);
237 0 0         my @d=((defined $rd->{account_id} ? ['r:registrant',$rd->{account_id}] : ['r:domainName',$domain]),['r:registrarTag',$rd->{registrar_tag}]);
238 0           $mes->command_body(\@d);
239 0           return;
240             }
241              
242             # called by domain_transfer_accept
243             sub handshake_accept
244             {
245 0     0 0   my ($epp,$domain,$rd)=@_;
246 0           my $mes=$epp->message();
247 0 0         Net::DRI::Exception::usererr_insufficient_parameters('case_id is required') unless $rd->{case_id};
248 0           $mes->command(['update','h:accept',sprintf('xmlns:h="%s" xsi:schemaLocation="%s %s"',$mes->nsattrs('std-handshake'))]);
249 0           my @d=(['h:caseId',$rd->{case_id}]);
250 0 0         push @d, ['h:registrant',$rd->{'registrant'}] if $rd->{'registrant'};
251 0           $mes->command_body(\@d);
252 0           return;
253             }
254              
255             # called by domain_transfer_refuse
256             sub handshake_reject
257             {
258 0     0 0   my ($epp,$domain,$rd)=@_;
259 0           my $mes=$epp->message();
260 0 0         Net::DRI::Exception::usererr_insufficient_parameters('case_id is required') unless $rd->{case_id};
261 0           $mes->command(['update','h:reject',sprintf('xmlns:h="%s" xsi:schemaLocation="%s %s"',$mes->nsattrs('std-handshake'))]);
262 0           my @d=(['h:caseId',$rd->{case_id}]);
263 0           $mes->command_body(\@d);
264 0           return;
265             }
266              
267             sub lock ## no critic (Subroutines::ProhibitBuiltinHomonyms)
268             {
269 0     0 0   my ($epp,$domain,$rd)=@_;
270 0           my $mes=$epp->message();
271 0 0         Net::DRI::Exception::usererr_insufficient_parameters('Domain name required') unless $domain;
272 0 0 0       Net::DRI::Exception::usererr_insufficient_parameters('type must be set to investigation to lock a domain') unless $rd->{type} && $rd->{type} eq 'investigation';
273 0           $mes->command(['update','l:lock',sprintf('xmlns:l="%s" xsi:schemaLocation="%s %s"',$mes->nsattrs('std-locks')). ' object="domain" type="investigation"']);
274 0           my @d=(['l:domainName',$domain]);
275 0           $mes->command_body(\@d);
276 0           return;
277             }
278              
279             ####################################################################################################
280             1;