File Coverage

blib/lib/Net/DRI/Protocol/RRI/Domain.pm
Criterion Covered Total %
statement 21 334 6.2
branch 0 174 0.0
condition 0 72 0.0
subroutine 7 30 23.3
pod 0 23 0.0
total 28 633 4.4


line stmt bran cond sub pod time code
1             ## Domain Registry Interface, RRI Domain commands (DENIC-11)
2             ##
3             ## Copyright (c) 2007,2008 Tonnerre Lombard . All rights reserved.
4             ## (c) 2012,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::RRI::Domain;
17              
18 1     1   673 use strict;
  1         1  
  1         64  
19 1     1   4 use warnings;
  1         2  
  1         34  
20              
21             ##use IDNA::Punycode;
22 1     1   4 use DateTime::Format::ISO8601 ();
  1         2  
  1         11  
23              
24 1     1   3 use Net::DRI::Util;
  1         2  
  1         13  
25 1     1   3 use Net::DRI::Exception;
  1         1  
  1         17  
26 1     1   2 use Net::DRI::Data::Hosts;
  1         1  
  1         7  
27 1     1   21 use Net::DRI::Data::ContactSet;
  1         2  
  1         2888  
28              
29             =pod
30              
31             =head1 NAME
32              
33             Net::DRI::Protocol::RRI::Domain - RRI Domain commands (DENIC-11) 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             Etonnerre.lombard@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) 2007,2008 Tonnerre Lombard .
58             (c) 2012,2013 Michael Holloway .
59             All rights reserved.
60              
61             This program is free software; you can redistribute it and/or modify
62             it under the terms of the GNU General Public License as published by
63             the Free Software Foundation; either version 2 of the License, or
64             (at your option) any later version.
65              
66             See the LICENSE file that comes with this distribution for more details.
67              
68             =cut
69              
70             ####################################################################################################
71              
72             sub register_commands
73             {
74 0     0 0   my ($class,$version)=@_;
75 0           my %tmp=(
76             check => [ \&check, \&check_parse ],
77             info => [ \&info, \&info_parse ],
78             transfer_query => [ \&transfer_query, \&transfer_parse ],
79             create => [ \&create, \&create_parse ],
80             delete => [ \&delete ],
81             transfer_request => [ \&transfer_request ],
82             transfer_answer => [ \&transfer_answer ],
83             trade => [ \&trade ],
84             update => [ \&update],
85             transit => [ \&transit],
86             migrate_descr => [ \&migrate_descr],
87             create_authinfo => [ \&create_authinfo],
88             delete_authinfo => [ \&delete_authinfo],
89             );
90              
91 0           return { 'domain' => \%tmp };
92             }
93              
94             sub build_command
95             {
96 0     0 0   my ($msg, $command, $domain, $domainattr, $dns) = @_;
97 0 0         my @dom = (ref($domain))? @$domain : ($domain);
98 0 0         Net::DRI::Exception->die(1,'protocol/RRI', 2, 'Domain name needed')
99             unless @dom;
100 0           foreach my $d (@dom)
101             {
102 0 0 0       Net::DRI::Exception->die(1, 'protocol/RRI', 2, 'Domain name needed')
103             unless defined($d) && $d;
104 0 0         Net::DRI::Exception->die(1, 'protocol/RRI', 10, 'Invalid domain name: ' . $d)
105             unless Net::DRI::Util::is_hostname($d);
106             }
107              
108 0 0         my $tcommand = (ref($command)) ? $command->[0] : $command;
109 0           my @ns = @{$msg->ns->{domain}};
  0            
110 0 0         $msg->command(['domain', $tcommand, (defined($dns) ? $dns : $ns[0]), $domainattr]);
111              
112 0           my @d;
113              
114 0           foreach my $domain (@dom)
115             {
116             ##my $ace = join('.', map { decode_punycode($_) } split(/\./, $domain));
117 0           push @d, ['domain:handle', $domain];
118 0           push @d, ['domain:ace', $domain];
119             }
120 0           return @d;
121             }
122              
123             ####################################################################################################
124             ########### Query commands
125              
126             sub check
127             {
128 0     0 0   my ($rri, $domain, $rd)=@_;
129 0           my $mes = $rri->message();
130 0           my @d = build_command($mes, 'check', $domain);
131 0           $mes->command_body(\@d);
132 0           $mes->cltrid(undef);
133 0           return;
134             }
135              
136              
137             sub check_parse
138             {
139 0     0 0   my ($po,$otype,$oaction,$oname,$rinfo)=@_;
140 0           my $mes = $po->message();
141 0 0         return unless $mes->is_success();
142              
143 0           my $chkdata = $mes->get_content('checkData',$mes->ns('domain'));
144 0 0         return unless $chkdata;
145 0           my @d = $chkdata->getElementsByTagNameNS($mes->ns('domain'),'handle');
146 0           my @s = $chkdata->getElementsByTagNameNS($mes->ns('domain'),'status');
147 0 0 0       return unless (@d && @s);
148              
149 0           my $dom = $d[0]->getFirstChild()->getData();
150 0           $rinfo->{domain}->{$dom}->{action} = 'check';
151 0 0         $rinfo->{domain}->{$dom}->{exist} = ($s[0]->getFirstChild()->getData() eq 'free')? 0 : 1;
152 0           return;
153             }
154              
155             sub info
156             {
157 0     0 0   my ($rri, $domain, $rd)=@_;
158 0           my $mes = $rri->message();
159 0 0 0       my $wp = (defined($rd->{'withProvider'} && $rd->{'withProvider'})) ? 'true' : 'false';
160 0           my @d = build_command($mes, 'info', $domain,
161             {recursive => 'false', withProvider => $wp});
162 0           $mes->command_body(\@d);
163 0           $mes->cltrid(undef);
164 0           return;
165             }
166              
167             sub info_parse
168             {
169 0     0 0   my ($po, $otype, $oaction, $oname, $rinfo) = @_;
170 0           my $mes = $po->message();
171 0 0         return unless $mes->is_success();
172 0           my $infdata = $mes->get_content('infoData', $mes->ns('domain'));
173 0 0         return unless $infdata;
174 0           my $cs = Net::DRI::Data::ContactSet->new();
175 0           my $ns = Net::DRI::Data::Hosts->new();
176 0           my $c = $infdata->getFirstChild();
177              
178 0           while ($c)
179             {
180 0 0         next unless ($c->nodeType() == 1); ## only for element nodes
181 0   0       my $name = $c->localname() || $c->nodeName();
182 0 0         next unless $name;
183              
184 0 0         if ($name eq 'handle')
    0          
    0          
    0          
    0          
    0          
    0          
185             {
186 0           $oname = lc($c->getFirstChild()->getData());
187 0           $rinfo->{domain}->{$oname}->{action} = 'info';
188 0           $rinfo->{domain}->{$oname}->{exist} = 1;
189             }
190             elsif ($name eq 'status')
191             {
192 0           my $val = $c->getFirstChild()->getData();
193 0 0         $rinfo->{domain}->{$oname}->{exist} = ($val eq 'connect')? 1 : 0;
194             }
195             elsif ($name eq 'contact')
196             {
197 0           my $role = $c->getAttribute('role');
198 0           my %rmap = ('holder' => 'registrant', 'admin-c' => 'admin',
199             'tech-c' => 'tech', 'zone-c' => 'zone');
200 0           my @hndl_tags = $c->getElementsByTagNameNS($mes->ns('contact'),'handle');
201 0           my $hndl_tag = $hndl_tags[0];
202 0 0         $role = $rmap{$role} if (defined($rmap{$role}));
203 0 0 0       $cs->add($po->create_local_object('contact')->srid($hndl_tag->getFirstChild()->getData()), $role)
204             if (defined($hndl_tag) && defined($hndl_tag->getFirstChild()));
205             }
206             elsif ($name eq 'dnsentry')
207             {
208 0           $ns->add(parse_ns($mes,$c));
209             }
210             elsif ($name eq 'regAccId')
211             {
212             $rinfo->{domain}->{$oname}->{clID} =
213             $rinfo->{domain}->{$oname}->{crID} =
214 0           $rinfo->{domain}->{$oname}->{upID} = $c->getFirstChild()->getData();
215             }
216             elsif ($name eq 'changed')
217             {
218             $rinfo->{domain}->{$oname}->{crDate} =
219             $rinfo->{domain}->{$oname}->{upDate} =
220 0           DateTime::Format::ISO8601->new()->
221             parse_datetime($c->getFirstChild()->getData());
222             }
223             elsif ($name eq 'chprovData')
224             {
225             # FIXME: Implement this one as well
226             }
227 0           } continue { $c = $c->getNextSibling(); }
228              
229 0           $rinfo->{domain}->{$oname}->{contact} = $cs;
230 0           $rinfo->{domain}->{$oname}->{status} = $po->create_local_object('status');
231 0           $rinfo->{domain}->{$oname}->{ns} = $ns;
232 0           return;
233             }
234              
235             sub parse_ns
236             {
237 0     0 0   my $mes = shift;
238 0           my $node = shift;
239 0           my $n = $node->getFirstChild();
240 0           my $hostname = '';
241 0           my @ip4 = ();
242 0           my @ip6 = ();
243              
244 0           while ($n)
245             {
246 0 0         next unless ($n->nodeType() == 1); ## only for element nodes
247 0   0       my $name = $n->localname() || $n->nodeName();
248 0 0         next unless $name;
249              
250 0 0         if ($name eq 'rdata')
251             {
252 0           my $nn = $n->getFirstChild();
253 0           while ($nn)
254             {
255 0 0         next unless ($nn->nodeType() == 1); ## only for element nodes
256 0   0       my $name2 = $nn->localname() || $nn->nodeName();
257 0 0         next unless $name2;
258 0 0         if ($name2 eq 'nameserver')
    0          
259             {
260 0           $hostname = $nn->getFirstChild()->getData();
261 0 0         $hostname =~ s/\.$// if ($hostname =~ /\.$/);
262             }
263             elsif ($name2 eq 'address')
264             {
265 0           my $ip = $nn->getFirstChild()->getData();
266 0 0         if ($ip=~m/:/)
267             {
268 0           push @ip6, $ip;
269             }
270             else
271             {
272 0           push @ip4, $ip;
273             }
274             }
275 0           } continue { $nn = $nn->getNextSibling(); }
276             }
277 0           } continue { $n = $n->getNextSibling(); }
278              
279 0           return ($hostname, \@ip4, \@ip6);
280             }
281              
282             sub transfer_query
283             {
284 0     0 0   my ($rri, $domain, $rd)=@_;
285 0           my $mes = $rri->message();
286 0           my @d = build_command($mes, 'info', $domain,
287             {recursive => 'true', withProvider => 'false'});
288 0           $mes->command_body(\@d);
289 0           return;
290             }
291              
292             sub transfer_parse
293             {
294 0     0 0   my ($po, $otype, $oaction, $oname, $rinfo) = @_;
295 0           my $mes = $po->message();
296 0 0         return unless $mes->is_success();
297              
298 0           my $infodata = $mes->get_content('infoData', $mes->ns('domain'));
299 0 0         return unless $infodata;
300 0           my $namedata = ($infodata->getElementsByTagNameNS($mes->ns('domain'),
301             'handle'))[0];
302 0 0         return unless $namedata;
303 0           my $trndata = ($infodata->getElementsByTagNameNS($mes->ns('domain'),
304             'chprovData'))[0];
305 0 0         return unless $trndata;
306              
307 0           $oname = lc($namedata->getFirstChild()->getData());
308 0           $rinfo->{domain}->{$oname}->{action} = 'transfer';
309 0           $rinfo->{domain}->{$oname}->{exist} = 1;
310 0           $rinfo->{domain}->{$oname}->{trStatus} = undef;
311              
312 0           my $c = $trndata->getFirstChild();
313 0           while ($c)
314             {
315 0 0         next unless ($c->nodeType() == 1); ## only for element nodes
316 0   0       my $name = $c->localname() || $c->nodeName();
317 0 0         next unless $name;
318              
319 0 0         if ($name eq 'chprovTo')
    0          
    0          
320             {
321 0           $rinfo->{domain}->{$oname}->{reID} = $c->getFirstChild()->getData();
322             }
323             elsif ($name eq 'chprovStatus')
324             {
325 0           my %stmap = (ACTIVE => 'pending', REMINDED => 'pending');
326 0           my $val = $c->getFirstChild()->getData();
327             $rinfo->{domain}->{$oname}->{trStatus} =
328 0 0         (defined($stmap{$val}) ? $stmap{$val} : $val);
329             }
330             elsif ($name =~ m/^(chprovStart|chprovReminder|chprovEnd)$/)
331             {
332 0           my %tmmap = (chprovStart => 'reDate', chprovReminder => 'acDate',
333             chprovEnd => 'exDate');
334 0           $rinfo->{domain}->{$oname}->{$tmmap{$1}} = DateTime::Format::ISO8601->
335             new()->parse_datetime($c->getFirstChild()->getData());
336             }
337 0           } continue { $c = $c->getNextSibling(); }
338 0           return;
339             }
340              
341             ############ Transform commands
342              
343             sub create
344             {
345 0     0 0   my ($rri, $domain, $rd) = @_;
346 0           my $mes = $rri->message();
347 0           my %ns = map { $_ => $mes->ns->{$_}->[0] } qw(domain dnsentry xsi);
  0            
348 0           my @d = build_command($mes, 'create', $domain, undef, \%ns);
349            
350 0           my $def = $rri->default_parameters();
351 0 0 0       if ($def && (ref($def) eq 'HASH') && exists($def->{domain_create}) &&
      0        
      0        
352             (ref($def->{domain_create}) eq 'HASH'))
353             {
354 0 0 0       $rd = {} unless ($rd && (ref($rd) eq 'HASH') && keys(%$rd));
      0        
355 0           while (my ($k, $v) = each(%{$def->{domain_create}}))
  0            
356             {
357 0 0         next if exists($rd->{$k});
358 0           $rd->{$k} = $v;
359             }
360             }
361              
362             ## Contacts, all OPTIONAL
363 0 0         push @d,build_contact($rd->{contact}) if Net::DRI::Util::has_contact($rd);
364              
365             ## Nameservers, OPTIONAL
366 0 0         push @d,build_ns($rri,$rd->{ns},$domain) if Net::DRI::Util::has_ns($rd);
367              
368 0 0         push @d,build_secdns($rd->{secdns},$domain) if $rd->{secdns};
369              
370 0           $mes->command_body(\@d);
371 0           return;
372             }
373              
374             sub build_contact
375             {
376 0     0 0   my $cs = shift;
377 0           my @d;
378              
379 0           my %trans = ('registrant' => 'holder', 'admin' => 'admin-c',
380             'tech' => 'tech-c', 'zone' => 'zone-c');
381              
382             # All nonstandard contacts go into the extension section
383 0           foreach my $t (sort($cs->types()))
384             {
385 0           my @o = $cs->get($t);
386 0 0         my $c = (defined($trans{$t}) ? $trans{$t} : $t);
387 0           push @d, map { ['domain:contact', $_->srid(), {'role' => $c}] } @o;
  0            
388             }
389 0           return @d;
390             }
391              
392             sub build_ns
393             {
394 0     0 0   my ($rri,$ns,$domain,$xmlns)=@_;
395 0           my @d;
396              
397 0           foreach my $i (1..$ns->count())
398             {
399 0           my ($n, $v4, $v6) = $ns->get_details($i);
400 0           my @h = map { ['dnsentry:address', $_] } (@{$v4}, @{$v6});
  0            
  0            
  0            
401 0           push @d, ['dnsentry:dnsentry', {'xsi:type' => 'dnsentry:NS'},
402             ['dnsentry:owner', $domain . '.'],
403             ['dnsentry:rdata', ['dnsentry:nameserver', $n . '.' ], @h ] ];
404             }
405 0 0         $xmlns='dnsentry' unless defined($xmlns);
406 0           return @d;
407             }
408              
409             sub build_secdns
410             {
411 0     0 0   my ($secdns,$domain)=@_;
412 0 0         return unless $secdns;
413 0           my @d;
414 0           foreach my $s (@{$secdns}) {
  0            
415 0 0         next unless $s->{key_flags};
416 0 0         Net::DRI::Exception::usererr_invalid_parameters('key_flags mut be a 16-bit unsigned integer: '.$s->{key_flags}) unless Net::DRI::Util::verify_ushort($s->{key_flags});
417 0 0         Net::DRI::Exception::usererr_invalid_parameters('key_protocol must be an unsigned byte: '.$s->{key_protocol}) unless Net::DRI::Util::verify_ubyte($s->{key_protocol});
418 0 0         Net::DRI::Exception::usererr_invalid_parameters('key_alg must be an unsigned byte: '.$s->{key_alg}) unless Net::DRI::Util::verify_ubyte($s->{key_alg});
419 0 0         Net::DRI::Exception::usererr_invalid_parameters('key_pubKey must be a non empty base64 string: '.$s->{key_pubKey}) unless Net::DRI::Util::verify_base64($s->{key_pubKey},1);
420             push @d, ['dnsentry:dnsentry', {'xsi:type' => 'dnsentry:DNSKEY'},
421             ['dnsentry:owner', $domain . '.'],
422             ['dnsentry:rdata',
423             ['dnsentry:flags', $s->{'key_flags'}],
424             ['dnsentry:protocol', $s->{'key_protocol'}],
425             ['dnsentry:algorithm', $s->{'key_alg'}],
426 0           ['dnsentry:publicKey', $s->{'key_pubKey'}] ] ];
427             }
428 0           return @d;
429             }
430              
431             sub create_parse
432             {
433 0     0 0   my ($po, $otype, $oaction, $oname, $rinfo) = @_;
434 0           my $mes = $po->message();
435 0 0         return unless $mes->is_success();
436              
437 0           my $credata = $mes->get_content('creData', $mes->ns('domain'));
438 0 0         return unless $credata;
439              
440 0           my $c = $credata->getFirstChild();
441 0           while ($c)
442             {
443 0 0         next unless ($c->nodeType() == 1); ## only for element nodes
444 0   0       my $name = $c->localname() || $c->nodeName();
445 0 0         next unless $name;
446              
447 0 0         if ($name eq 'name')
    0          
448             {
449 0           $oname = lc($c->getFirstChild()->getData());
450 0           $rinfo->{domain}->{$oname}->{action} = 'create';
451 0           $rinfo->{domain}->{$oname}->{exist} = 1;
452             }
453             elsif ($name =~ m/^(crDate|exDate)$/)
454             {
455 0           $rinfo->{domain}->{$oname}->{$1} = DateTime::Format::ISO8601->new()->
456             parse_datetime($c->getFirstChild()->getData());
457             }
458 0           } continue { $c = $c->getNextSibling(); }
459 0           return;
460             }
461              
462             sub delete ## no critic (Subroutines::ProhibitBuiltinHomonyms)
463             {
464 0     0 0   my ($rri, $domain, $rd) = @_;
465 0           my $mes = $rri->message();
466 0           my @d = build_command($mes, 'delete', $domain);
467              
468             ## Holder contact
469 0 0         if (Net::DRI::Util::has_contact($rd))
470             {
471 0           my $ocs = $rd->{contact};
472 0           my $cs = Net::DRI::Data::ContactSet->new();
473 0           foreach my $c ($ocs->get('registrant'))
474             {
475 0           $cs->add($c, 'registrant');
476             }
477              
478 0           push @d, build_contact($cs);
479             }
480              
481 0           $mes->command_body(\@d);
482 0           return;
483             }
484              
485             sub transfer_request
486             {
487 0     0 0   my ($rri, $domain, $rd) = @_;
488 0           my $mes = $rri->message();
489 0           my %ns = map { $_ => $mes->ns->{$_}->[0] } qw(domain dnsentry xsi);
  0            
490 0           my @d = build_command($mes, 'chprov', $domain, undef, \%ns);
491              
492             ## Contacts, all OPTIONAL
493 0 0         push @d,build_contact($rd->{contact}) if Net::DRI::Util::has_contact($rd);
494              
495             ## Nameservers, OPTIONAL
496 0 0         push @d, build_ns($rri, $rd->{ns}, $domain) if Net::DRI::Util::has_ns($rd);
497              
498 0 0         push @d, ['domain:authInfo',$rd->{auth}->{pw}] if $rd->{auth};
499              
500 0           $mes->command_body(\@d);
501 0           return;
502             }
503              
504             sub transfer_answer
505             {
506 0     0 0   my ($rri, $domain, $rd) = @_;
507 0           my $mes = $rri->message();
508 0 0 0       my @d = build_command($mes, (Net::DRI::Util::has_key($rd,'approve') && $rd->{approve}) ?
509             'chprovAck' : 'chprovNack', $domain);
510 0           $mes->command_body(\@d);
511 0           return;
512             }
513              
514             sub trade
515             {
516 0     0 0   my ($rri, $domain, $rd) = @_;
517 0           my $mes = $rri->message();
518 0           my %ns = map { $_ => $mes->ns->{$_}->[0] } qw(domain dnsentry xsi);
  0            
519 0           my @d = build_command($mes, 'chholder', $domain, undef, \%ns);
520              
521 0           my $def = $rri->default_parameters();
522 0 0 0       if ($def && (ref($def) eq 'HASH') && exists($def->{domain_create}) &&
      0        
      0        
523             (ref($def->{domain_create}) eq 'HASH'))
524             {
525 0 0 0       $rd = {} unless ($rd && (ref($rd) eq 'HASH') && keys(%$rd));
      0        
526 0           while (my ($k, $v) = each(%{$def->{domain_create}}))
  0            
527             {
528 0 0         next if exists($rd->{$k});
529 0           $rd->{$k} = $v;
530             }
531             }
532              
533             ## Contacts, all OPTIONAL
534 0 0         push @d,build_contact($rd->{contact}) if Net::DRI::Util::has_contact($rd);
535              
536             ## Nameservers, OPTIONAL
537 0 0         push @d, build_ns($rri, $rd->{ns}, $domain) if Net::DRI::Util::has_ns($rd);
538              
539 0           $mes->command_body(\@d);
540 0           return;
541             }
542              
543             sub transit {
544 0     0 0   my ($rri, $domain, $rd) = @_;
545 0           my $mes = $rri->message();
546 0 0 0       my $disconnect = ( exists($rd->{disconnect}) && $rd->{disconnect} eq 'true' ) ? { disconnect => 'true'} : undef;
547 0           my %ns = map { $_ => $mes->ns->{$_}->[0] } qw(domain dnsentry xsi);
  0            
548 0           my @d = build_command($mes, 'transit', $domain, $disconnect, \%ns);
549              
550 0           $mes->command_body(\@d);
551 0           return;
552             }
553              
554             sub migrate_descr {
555 0     0 0   my ($rri, $domain, $rd) = @_;
556 0           my $mes = $rri->message();
557 0           my %ns = map { $_ => $mes->ns->{$_}->[0] } qw(domain dnsentry xsi);
  0            
558 0           my @d = build_command($mes, 'migrate-descr', $domain, undef, \%ns);
559              
560             ## Contacts, Holder is required
561 0 0         push @d,build_contact($rd->{contact}) if Net::DRI::Util::has_contact($rd);
562              
563 0           $mes->command_body(\@d);
564 0           return;
565             }
566              
567             sub create_authinfo {
568 0     0 0   my ($rri, $domain, $rd) = @_;
569 0           my $mes = $rri->message();
570 0           my %ns = map { $_ => $mes->ns->{$_}->[0] } qw(domain dnsentry xsi);
  0            
571 0 0         my $hash = exists($rd->{'authinfohash'}) ? { hash => $rd->{'authinfohash'}} : undef;
572 0 0 0       $hash->{'expire'} = $rd->{'authinfoexpire'} if ($hash && exists($rd->{'authinfoexpire'}));
573 0 0         my $cmd = ($hash) ? 'createAuthInfo1' : 'createAuthInfo2';
574 0           my @d = build_command($mes, $cmd, $domain, $hash, \%ns);
575 0           $mes->command_body(\@d);
576 0           return;
577             }
578              
579             sub delete_authinfo {
580 0     0 0   my ($rri, $domain, $rd) = @_;
581 0           my $mes = $rri->message();
582 0           my %ns = map { $_ => $mes->ns->{$_}->[0] } qw(domain dnsentry xsi);
  0            
583 0           my @d = build_command($mes, 'deleteAuthInfo1', $domain, undef, \%ns);
584 0           $mes->command_body(\@d);
585 0           return;
586             }
587              
588             sub update
589             {
590 0     0 0   my ($rri, $domain, $todo, $rd)=@_;
591 0           my $mes = $rri->message();
592 0           my %ns = map { $_ => $mes->ns->{$_}->[0] } qw(domain dnsentry xsi);
  0            
593 0           my $ns = $rd->{ns};
594 0           my $cs = $rd->{contact};
595              
596 0 0         Net::DRI::Exception::usererr_invalid_parameters($todo.' must be a Net::DRI::Data::Changes object') unless Net::DRI::Util::isa_changes($todo);
597              
598 0 0 0       Net::DRI::Exception::usererr_invalid_parameters('Must specify contact set and name servers with update command (or use the proper API)') unless (Net::DRI::Util::isa_contactset($cs) && Net::DRI::Util::isa_hosts($ns));
599              
600 0 0 0       if ((grep { ! /^(?:add|del)$/ } $todo->types('ns')) ||
  0            
601 0           (grep { ! /^(?:add|del)$/ } $todo->types('contact')))
602             {
603 0           Net::DRI::Exception->die(0, 'protocol/RRI', 11, 'Only ns/status/contact add/del or registrant/authinfo set available for domain');
604             }
605              
606 0           my @d = build_command($mes, 'update', $domain, undef, \%ns);
607              
608 0           my $nsadd = $todo->add('ns');
609 0           my $nsdel = $todo->del('ns');
610 0           my $cadd = $todo->add('contact');
611 0           my $cdel = $todo->del('contact');
612              
613 0 0         if (defined($nsadd)) { foreach my $hostname ($nsadd->get_names())
  0            
614             {
615 0           $ns->add($nsadd->get_details($hostname));
616             } }
617              
618 0 0         if (defined($nsdel))
619             {
620 0           my $newns =Net::DRI::Data::Hosts->new();
621              
622 0           foreach my $hostname ($ns->get_names())
623             {
624 0 0         if (!grep { $_ eq $hostname } $nsdel->get_names())
  0            
625             {
626 0           $newns->add($ns->get_details($hostname));
627             }
628             }
629              
630 0           $ns = $newns;
631             }
632              
633 0 0         if (defined($cadd)) { foreach my $type ($cadd->types()) {
  0            
634 0           foreach my $c ($cadd->get($type))
635             {
636 0           $cs->add($c, $type);
637             }
638             } }
639              
640 0 0         if (defined($cdel)) { foreach my $type ($cdel->types()) {
  0            
641 0           foreach my $c ($cdel->get($type))
642             {
643 0           $cs->del($c, $type);
644             }
645             } }
646              
647 0           push @d, build_contact($cs);
648 0           push @d, build_ns($rri, $ns, $domain);
649              
650 0           $mes->command_body(\@d);
651 0           return;
652             }
653              
654             ####################################################################################################
655             1;