File Coverage

blib/lib/Net/DRI/Protocol/EPP/Extensions/CZ/Domain.pm
Criterion Covered Total %
statement 24 138 17.3
branch 0 88 0.0
condition 0 45 0.0
subroutine 8 16 50.0
pod 0 8 0.0
total 32 295 10.8


line stmt bran cond sub pod time code
1             ## Domain Registry Interface, CZ domain transactions extension
2             ##
3             ## Copyright (c) 2008-2010,2013 Tonnerre Lombard .
4             ## 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::CZ::Domain;
17              
18 1     1   793 use strict;
  1         2  
  1         30  
19 1     1   4 use warnings;
  1         2  
  1         22  
20              
21 1     1   3 use Net::DRI::Util;
  1         1  
  1         25  
22 1     1   3 use Net::DRI::Exception;
  1         1  
  1         14  
23 1     1   4 use Net::DRI::Data::ContactSet;
  1         2  
  1         19  
24 1     1   5 use Net::DRI::Data::Hosts;
  1         1  
  1         8  
25 1     1   21 use Net::DRI::Protocol::EPP::Util;
  1         2  
  1         18  
26              
27 1     1   5 use DateTime::Format::ISO8601;
  1         2  
  1         2075  
28              
29             =pod
30              
31             =head1 NAME
32              
33             Net::DRI::Protocol::EPP::Extensions::CZ::Domain - .CZ Domain extension commands for Net::DRI
34              
35             =head1 DESCRIPTION
36              
37             Please see the README file for details.
38              
39             =head1 SUPPORT
40              
41             For now, support questions should be sent to:
42              
43             Edevelopment@sygroup.chE
44              
45             Please also see the SUPPORT file in the distribution.
46              
47             =head1 SEE ALSO
48              
49             Ehttp://oss.bsdprojects.net/projects/netdri/E
50              
51             =head1 AUTHOR
52              
53             Tonnerre Lombard, Etonnerre.lombard@sygroup.chE
54              
55             =head1 COPYRIGHT
56              
57             Copyright (c) 2008-2010,2013 Tonnerre Lombard .
58             All rights reserved.
59              
60             This program is free software; you can redistribute it and/or modify
61             it under the terms of the GNU General Public License as published by
62             the Free Software Foundation; either version 2 of the License, or
63             (at your option) any later version.
64              
65             See the LICENSE file that comes with this distribution for more details.
66              
67             =cut
68              
69             ####################################################################################################
70              
71             sub register_commands
72             {
73 0     0 0   my ($class, $version) = @_;
74 0           my %tmp = (
75             info => [ \&info, \&info_parse ],
76             create => [ \&create, undef ],
77             update => [ \&update ],
78             );
79            
80 0           return { 'domain' => \%tmp };
81             }
82              
83             ##################################################################################################
84              
85             sub build_command
86             {
87 0     0 0   my ($msg, $command, $domain, $domainattr) = @_;
88 0 0         my @dom = (ref($domain)) ? @$domain : ($domain);
89 0 0         Net::DRI::Exception->die(1, 'protocol/EPP', 2, "Domain name needed")
90             unless @dom;
91              
92 0           foreach my $d (@dom)
93             {
94 0 0 0       Net::DRI::Exception->die(1, 'protocol/EPP', 2,
      0        
95             'Domain name needed') unless (defined($d) && $d && !ref($d));
96 0 0         Net::DRI::Exception->die(1, 'protocol/EPP', 10,
97             'Invalid domain name: ' . $d)
98             unless (Net::DRI::Util::is_hostname($d));
99             }
100              
101 0 0         my $tcommand = (ref($command)) ? $command->[0] : $command;
102 0           $msg->command([$command, 'domain:' . $tcommand,
103             sprintf('xmlns:domain="%s" xsi:schemaLocation="%s %s"',$msg->nsattrs('domain'))]);
104 0           my @d = map { ['domain:name', $_, $domainattr] } @dom;
  0            
105 0           return @d;
106             }
107              
108             sub build_authinfo
109             {
110 0     0 0   my $rauth = shift;
111 0           return ['domain:authInfo', $rauth->{pw}];
112             }
113              
114             ####################################################################################################
115             ########### Query commands
116              
117             sub info
118             {
119 0     0 0   my ($epp, $domain, $rd) = @_;
120 0           my $mes = $epp->message();
121 0           my @d = build_command($mes, 'info', $domain);
122 0 0         push(@d, build_authinfo($rd->{auth})) if Net::DRI::Util::has_auth($rd);
123 0           $mes->command_body(\@d);
124 0           return;
125             }
126              
127             sub info_parse
128             {
129 0     0 0   my ($po, $otype, $oaction, $oname, $rinfo) = @_;
130 0           my $mes = $po->message();
131 0 0         return unless $mes->is_success();
132 0           my $infdata = $mes->get_response('domain','infData');
133 0 0         return unless $infdata;
134 0           my (@s, @host, $ns);
135 0           my $cs = Net::DRI::Data::ContactSet->new();
136 0           my $c = $infdata->getFirstChild();
137              
138 0           while ($c)
139             {
140 0   0       my $name = $c->localname() || $c->nodeName();
141 0 0         next unless $name;
142 0 0         if ($name eq 'name')
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
143             {
144 0           $oname = lc($c->getFirstChild()->getData());
145 0           $rinfo->{domain}->{$oname}->{action} = 'info';
146 0           $rinfo->{domain}->{$oname}->{exist} = 1;
147             }
148             elsif ($name eq 'roid')
149             {
150 0           $rinfo->{domain}->{$oname}->{roid} =
151             $c->getFirstChild()->getData();
152             }
153             elsif ($name eq 'status')
154             {
155 0           push(@s, Net::DRI::Protocol::EPP::Util::parse_node_status($c));
156             }
157             elsif ($name =~ /^(registrant|admin)$/)
158             {
159 0           $cs->set($po->create_local_object('contact')->srid($c->getFirstChild()->getData()),
160             $1);
161             }
162             elsif ($name eq 'ns')
163             {
164 0 0         $ns = Net::DRI::Data::Hosts->new() if (!$ns);
165 0           $ns->add($c->getFirstChild()->getData());
166             }
167             elsif ($name eq 'nsset')
168             {
169 0           $rinfo->{domain}->{$oname}->{nsset} =
170             $c->getFirstChild()->getData();
171             }
172             elsif ($name eq 'host')
173             {
174 0           push(@host, $c->getFirstChild()->getData());
175             }
176             elsif ($name =~ m/^(clID|crID|upID)$/)
177             {
178 0           $rinfo->{domain}->{$oname}->{$1} =
179             $c->getFirstChild()->getData();
180             }
181             elsif ($name =~ m/^(crDate|upDate|trDate|exDate)$/)
182             {
183 0           $rinfo->{domain}->{$oname}->{$1} =
184             DateTime::Format::ISO8601->new()->
185             parse_datetime($c->getFirstChild()->
186             getData());
187             }
188             elsif ($name eq 'authInfo')
189             {
190 0           my $pw = $c->getFirstChild()->getData();
191 0 0         $rinfo->{domain}->{$oname}->{auth} =
192             {pw => ($pw ? $pw : undef) };
193             }
194              
195 0           $c = $c->getNextSibling();
196             }
197              
198 0           $rinfo->{domain}->{$oname}->{contact} = $cs;
199 0           $rinfo->{domain}->{$oname}->{status} = $po->
200             create_local_object('status')->add(@s);
201 0 0         $rinfo->{domain}->{$oname}->{host} = Net::DRI::Data::Hosts->
202             new_set(@host) if (@host);
203 0 0         $rinfo->{domain}->{$oname}->{ns} = $ns if ($ns);
204 0           return;
205             }
206              
207             ############ Transform commands
208              
209             sub create
210             {
211 0     0 0   my ($epp, $domain, $rd) = @_;
212 0           my $mes = $epp->message();
213 0           my @d = build_command($mes, 'create', $domain);
214 0           my $def = $epp->default_parameters();
215            
216 0 0 0       if ($def && (ref($def) eq 'HASH') && exists($def->{domain_create}) &&
      0        
      0        
217             (ref($def->{domain_create}) eq 'HASH'))
218             {
219 0 0 0       $rd = {} unless ($rd && (ref($rd) eq 'HASH') && keys(%$rd));
      0        
220              
221 0           while (my ($k, $v) = each(%{$def->{domain_create}}))
  0            
222             {
223 0 0         next if exists($rd->{$k});
224 0           $rd->{$k} = $v;
225             }
226             }
227              
228             ## Period, OPTIONAL
229 0 0         push(@d, Net::DRI::Protocol::EPP::Util::build_period($rd->{duration})) if Net::DRI::Util::has_duration($rd);
230              
231             ## Nameserver sets, OPTIONAL
232 0 0         push(@d, ['domain:nsset', $rd->{nsset}]) if (Net::DRI::Util::has_key($rd, 'nsset'));
233              
234             ## Contacts, all OPTIONAL
235 0 0         push(@d, build_contacts($rd->{contact})) if (Net::DRI::Util::has_contact($rd));
236              
237             ## AuthInfo
238 0 0         Net::DRI::Exception::usererr_insufficient_parameters('authInfo is ' .
239             'mandatory')
240             unless (Net::DRI::Util::has_auth($rd));
241 0           push(@d, build_authinfo($rd->{auth}));
242 0           $mes->command_body(\@d);
243 0           return;
244             }
245              
246             sub build_contacts
247             {
248 0     0 0   my $cs = shift;
249 0           my @d;
250              
251 0           foreach my $t (sort { $b cmp $a } $cs->types())
  0            
252             {
253 0           my @o = $cs->get($t);
254 0           push(@d, map { ['domain:' . $t, $_->srid()] } @o);
  0            
255             }
256              
257 0           return @d;
258             }
259              
260             sub update
261             {
262 0     0 0   my ($epp, $domain, $todo) = @_;
263 0           my $mes = $epp->message();
264              
265 0 0         Net::DRI::Exception::usererr_invalid_parameters($todo .
266             ' must be a Net::DRI::Data::Changes object') unless
267             Net::DRI::Util::isa_changes($todo);
268              
269 0 0 0       if ((grep { ! /^(?:add|del)$/ } $todo->types('ns')) ||
  0   0        
  0   0        
270 0           (grep { ! /^(?:add|del)$/ } $todo->types('status')) ||
271 0           (grep { ! /^(?:add|del)$/ } $todo->types('contact')) ||
272             (grep { ! /^set$/ } $todo->types('auth')))
273             {
274 0           Net::DRI::Exception->die(0, 'protocol/EPP', 11,
275             'Only ns/status/contact add/del or registrant/' .
276             'authinfo set available for domain');
277             }
278              
279 0           my @d = build_command($mes, 'update', $domain);
280              
281 0           my $nsadd = $todo->add('ns');
282 0           my $nsdel = $todo->del('ns');
283 0           my $sadd = $todo->add('status');
284 0           my $sdel = $todo->del('status');
285 0           my $cadd = $todo->add('contact');
286 0           my $cdel = $todo->del('contact');
287 0           my (@add, @del);
288              
289 0 0 0       push(@add, Net::DRI::Protocol::EPP::Util::build_ns($epp, $nsadd, $domain)) if ($nsadd &&
290             !$nsadd->is_empty());
291 0 0         push(@add, build_contacts($cadd)) if ($cadd);
292 0 0         push(@add, $sadd->build_xml('domain:status', 'core')) if ($sadd);
293 0 0 0       push(@del, Net::DRI::Protocol::EPP::Util::build_ns($epp, $nsdel, $domain)) if ($nsdel &&
294             !$nsdel->is_empty());
295 0 0         push(@del, build_contacts($cdel)) if ($cdel);
296 0 0         push(@del, $sdel->build_xml('domain:status', 'core')) if ($sdel);
297              
298 0 0         push(@d, ['domain:add', @add]) if (@add);
299 0 0         push(@d, ['domain:rem', @del]) if (@del);
300              
301 0           my @chg;
302 0           my $chg = $todo->set('nsset');
303 0 0 0       push(@chg, ['domain:nsset', $chg]) if (defined($chg) && length($chg));
304 0           $chg = $todo->set('registrant');
305 0 0         push(@chg, ['domain:registrant', $chg->srid()])
306             if Net::DRI::Util::isa_contact($chg);
307 0           $chg = $todo->set('auth');
308 0 0 0       push(@chg, build_authinfo($chg)) if ($chg && ref($chg));
309 0 0         push(@d, ['domain:chg', @chg]) if (@chg);
310              
311 0           $mes->command_body(\@d);
312 0           return;
313             }
314              
315             ####################################################################################################
316             1;