File Coverage

blib/lib/Net/DRI/DRD.pm
Criterion Covered Total %
statement 232 797 29.1
branch 78 484 16.1
condition 43 253 17.0
subroutine 33 122 27.0
pod 0 110 0.0
total 386 1766 21.8


line stmt bran cond sub pod time code
1             ## Domain Registry Interface, virtual superclass for all DRD modules
2             ##
3             ## Copyright (c) 2005-2013 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::DRD;
16              
17 69     69   1213 use strict;
  69         80  
  69         1515  
18 69     69   195 use warnings;
  69         74  
  69         1374  
19              
20 69     69   196 use base qw/Net::DRI::BaseClass/;
  69         69  
  69         4508  
21             __PACKAGE__->make_exception_if_not_implemented(qw/name tlds object_types periods profile_types transport_protocol_default/); ## methods that should be in subclasses
22              
23 69     69   26574 use DateTime;
  69         2540394  
  69         1745  
24 69     69   322 use DateTime::Duration;
  69         84  
  69         1097  
25              
26 69     69   219 use Net::DRI::Exception;
  69         82  
  69         1050  
27 69     69   194 use Net::DRI::Util;
  69         85  
  69         948  
28 69     69   28795 use Net::DRI::DRD::ICANN;
  69         125  
  69         1982  
29 69     69   833 use Net::DRI::Data::Raw;
  69         79  
  69         801  
30 69     69   1564 use Net::DRI::Protocol::ResultStatus;
  69         79  
  69         579  
31              
32             =pod
33              
34             =head1 NAME
35              
36             Net::DRI::DRD - Superclass of all Net::DRI Registry Drivers
37              
38             =head1 DESCRIPTION
39              
40             Please see the README file for details.
41              
42             =head1 SUBROUTINES/METHODS
43              
44             =head2 name()
45              
46             Name of this registry driver (this should not contain any dot at all)
47              
48             =head2 tlds()
49              
50             Array of tlds (lowercase, no starting or ending dot) handled by this registry
51              
52             =head2 object_types()
53              
54             Array of object types managed by this registry
55              
56             =head2 periods()
57              
58             Array of DateTime::Duration objects for valid domain name creation durations at registry
59              
60             =head1 SUPPORT
61              
62             For now, support questions should be sent to:
63              
64             Enetdri@dotandco.comE
65              
66             Please also see the SUPPORT file in the distribution.
67              
68             =head1 SEE ALSO
69              
70             Ehttp://www.dotandco.com/services/software/Net-DRI/E
71              
72             =head1 AUTHOR
73              
74             Patrick Mevzek, Enetdri@dotandco.comE
75              
76             =head1 COPYRIGHT
77              
78             Copyright (c) 2005-2013 Patrick Mevzek .
79             All rights reserved.
80              
81             This program is free software; you can redistribute it and/or modify
82             it under the terms of the GNU General Public License as published by
83             the Free Software Foundation; either version 2 of the License, or
84             (at your option) any later version.
85              
86             See the LICENSE file that comes with this distribution for more details.
87              
88             =cut
89              
90             ####################################################################################################
91              
92             sub new
93             {
94 66     66 0 129 my ($class,@r)=@_;
95 66 100       275 my $self={ info => defined $r[0] ? $r[0] : {} };
96 66         118 bless $self,$class;
97 66         140 return $self;
98             }
99              
100             sub info
101             {
102 1     1 0 3 my ($self,$ndr,$key)=@_;
103 1 50 33     7 $key=$ndr unless (defined $ndr && $ndr && (ref $ndr eq 'Net::DRI::Registry'));
      33        
104 1 50       3 return unless defined $self->{info};
105 1 50 33     8 return unless defined $key && exists $self->{info}->{$key};
106 1         2 return $self->{info}->{$key};
107             }
108              
109             sub is_my_tld
110             {
111 8     8 0 8 my ($self,$ndr,$domain,$strict)=@_;
112 8 50 33     46 ($domain,$strict)=($ndr,$domain) unless (defined($ndr) && $ndr && (ref($ndr) eq 'Net::DRI::Registry'));
      33        
113 8 50       11 if (! defined($strict)) { $strict=1; }
  8         9  
114 8 50       18 if ($domain=~m/\.e164\.arpa$/) { $strict=0; }
  0         0  
115 8         21 my $tlds=join('|',map { quotemeta($_) } sort { length($b) <=> length($a) } $self->tlds());
  47         55  
  79         63  
116 8 50       118 my $r=$strict? qr/^[^.]+\.(?:$tlds)$/i : qr/\.(?:$tlds)$/i;
117 8 50       75 return ($domain=~$r)? 1 : 0;
118             }
119              
120             sub _verify_name_rules
121             {
122 8     8   11 my ($self,$domain,$op,$rules)=@_;
123              
124 8 50 33     32 if (exists $rules->{check_name} && $rules->{check_name})
125             {
126 8         10 my $dots=$rules->{check_name_dots};
127 8 50       17 if (! defined $dots) { $dots=$self->dots(); }
  8         18  
128 8 50       25 my $r=$self->check_name($domain,$dots,exists $rules->{check_name_unicode} ? $rules->{check_name_unicode} : 0);
129 8 50       24 if (length $r) { return $r; }
  0         0  
130             }
131              
132 8 0 33     17 if (exists $rules->{check_name_no_dots} && $rules->{check_name_no_dots})
133             {
134 0         0 my $r=$self->check_name($domain);
135 0 0       0 if (length $r) { return $r; }
  0         0  
136             }
137              
138 8 50 33     48 if (exists $rules->{my_tld} && $rules->{my_tld} && ! $self->is_my_tld($domain)) { return 'NAME_NOT_IN_TLD'; }
  0   33     0  
139 8 0 33     17 if (exists $rules->{my_tld_not_strict} && $rules->{my_tld_not_strict} && ! $self->is_my_tld($domain,0)) { return 'NAME_NOT_IN_TLD'; }
  0   0     0  
140 8 50 66     20 if (exists $rules->{icann_reserved} && $rules->{icann_reserved})
141             {
142 7         17 my $ri=Net::DRI::DRD::ICANN::is_reserved_name($domain,$op);
143 7 50       13 return $ri if length $ri;
144             }
145              
146 8         16 my @d=split(/\./,$domain);
147 8 50 66     24 if (exists $rules->{min_length} && $rules->{min_length} && length($d[0]) < $rules->{min_length}) { return 'NAME_TOO_SHORT'; }
  0   33     0  
148 8 0 33     16 if (exists $rules->{no_double_hyphen} && $rules->{no_double_hyphen} && substr($d[0],2,2) eq '--') { return 'NAME_WITH_TWO_HYPHENS'; }
  0   0     0  
149 8 0 33     12 if (exists $rules->{no_double_hyphen_except_idn} && $rules->{no_double_hyphen_except_idn} && substr($d[0],2,2) eq '--' && substr($d[0],0,2) ne 'xn') { return 'NAME_WITH_TWO_HYPHENS_NOT_IDN'; }
  0   0     0  
      0        
150 8 0 33     12 if (exists $rules->{no_country_code} && $rules->{no_country_code} && exists $Net::DRI::Util::CCA2{uc($d[0])}) { return 'NAME_WITH_COUNTRY_CODE'; }
  0   0     0  
151 8 0 33     21 if (exists $rules->{no_digits_only} && $rules->{no_digits_only} && $d[0]=~m/^\d+$/) { return 'NAME_WITH_ONLY_DIGITS'; }
  0   0     0  
152              
153 8 50 33     20 if ($domain=~m/\.e164\.arpa$/ && $domain!~m/^(?:\d+\.)+e164\.arpa$/) { return 'NAME_INVALID_IN_E164'; }
  0         0  
154              
155 8 50       12 if (exists $rules->{excluded_labels})
156             {
157 0 0       0 my $n=join('|',ref $rules->{excluded_labels}? @{$rules->{excluded_labels}} : ($rules->{excluded_labels}));
  0         0  
158 0 0       0 if (lc($d[0])=~m/^(?:$n)$/o) { return 'NAME_WITH_EXCLUDED_LABELS'; }
  0         0  
159             }
160              
161             ## It seems all rules have passed successfully
162 8         16 return '';
163             }
164              
165             ## Compute the number of dots for each tld in tlds(), returns a ref array and store it for later quick access
166             sub dots
167             {
168 8     8 0 9 my ($self)=@_;
169 8 100       15 if (! exists $self->{dots})
170             {
171 2         9 my %a=map { $_ => 1 } map { my $r=$_; my $c=($r=~tr/\././); 1+$c; } $self->tlds();
  11         16  
  11         9  
  11         9  
  11         15  
172 2         11 $self->{dots}=[ sort { $a <=> $b } keys(%a) ];
  1         7  
173             }
174 8         15 return $self->{dots};
175             }
176              
177             sub has_object
178             {
179 0     0 0 0 my ($self,$ndr,$type)=@_;
180 0 0 0     0 $type=$ndr unless (defined($type) && ref($ndr));
181 0 0 0     0 return 0 unless (defined($type) && $type);
182 0         0 $type=lc($type);
183 0 0       0 return (grep { lc($_) eq $type } ($self->object_types()))? 1 : 0;
  0         0  
184             }
185              
186             ## TODO : use also protocol->has_action() ? (see end of domain_create)
187             sub registry_can
188             {
189 0     0 0 0 my ($self,$ndr,$what)=@_;
190 0 0 0     0 return (eval { $self->can($what); } && ! grep { $what eq $_ } $self->unavailable_operations())? 1 : 0;
191             }
192              
193             ## It would be probably more useful to know the list of available ones !
194             ## An overhaul would be probably needed when more non domain names registries are added
195 0     0 0 0 sub unavailable_operations { return (); } ## will be overruled by BaseClass, as needed
196              
197             ####################################################################################################
198              
199             ## A common default, which should be fine for EPP & related ways of doing things
200             ## (should it be done in the Protocol class instead ?)
201             sub domain_operation_needs_is_mine
202             {
203 0     0 0 0 my ($self,$ndr,$domain,$op)=@_;
204 0 0       0 if (! defined $op) { return; }
  0         0  
205 0 0       0 if ($op=~m/^(?:renew|update|delete)$/) { return 1; }
  0         0  
206 0 0       0 if ($op eq 'transfer') { return 0; }
  0         0  
207 0         0 return;
208             }
209              
210             ## This is the default basic one, it should get subclassed as needed
211             sub verify_name_domain
212             {
213 0     0 0 0 my ($self,$ndr,$domain,$op)=@_;
214 0         0 return $self->_verify_name_rules($domain,$op,{check_name=>1,my_tld=>1});
215             }
216              
217             sub verify_name_host
218             {
219 3     3 0 3 my ($self,$ndr,$host,$checktld)=@_;
220 3 50       5 $host=$host->get_names(1) if ref $host;
221 3         6 my $r=$self->check_name($host);
222 3 50       6 return $r if length $r;
223 3 0 33     6 return 'HOST_NAME_NOT_IN_CORRECT_TLD' if (defined $checktld && $checktld && !$self->is_my_tld($host,0));
      33        
224 3         4 return '';
225             }
226              
227             sub check_name
228             {
229 11     11 0 14 my ($self,$ndr,$data,$dots,$unicode)=@_;
230 11 50 33     67 ($data,$dots,$unicode)=($ndr,$data,$dots) unless (defined($ndr) && $ndr && (ref($ndr) eq 'Net::DRI::Registry'));
      33        
231              
232 11 50       19 return 'UNDEFINED_NAME' unless defined $data;
233 11 50       18 return 'NON_SCALAR_NAME' unless !ref($data);
234 11 50       19 return 'ZERO_LENGTH_NAME' unless length $data;
235 11 50       27 return 'INVALID_HOSTNAME' unless Net::DRI::Util::is_hostname($data,$unicode);
236 11 100 66     40 if (defined($dots) && $data!~m/\.e164\.arpa$/)
237             {
238 8         13 my @d=split(/\./,$data);
239 8 50       20 my @ok=ref($dots)? @$dots : ($dots);
240 8 50       9 return 'INVALID_NUMBER_OF_DOTS_IN_NAME' unless grep { 1+$_== @d } @ok;
  9         37  
241             }
242              
243 11         12 return ''; #everything ok
244             }
245              
246             sub verify_duration_create
247             {
248 1     1 0 2 my ($self,$ndr,$duration,$domain)=@_;
249              
250 1         5 my @d=$self->periods();
251 1 50       28 return 1 unless @d;
252 1 100       3 foreach my $d (@d) { return 0 if (0==Net::DRI::Util::compare_durations($d,$duration)) }
  10         13  
253 0         0 return 2;
254             }
255              
256             sub verify_duration_renew
257             {
258 1     1 0 3 my ($self,$ndr,$duration,$domain,$curexp)=@_;
259              
260 1         5 my @d=$self->periods();
261 1 50 33     33 if (defined($duration) && @d)
262             {
263 0         0 my $ok=0;
264 0         0 foreach my $d (@d)
265             {
266 0 0       0 next unless (0==Net::DRI::Util::compare_durations($d,$duration));
267 0         0 $ok=1;
268 0         0 last;
269             }
270 0 0       0 return 1 unless $ok;
271              
272 0 0 0     0 if (defined $curexp && Net::DRI::Util::is_class($curexp,'DateTime'))
273             {
274 0         0 my $maxdelta=$d[-1];
275 0         0 my $newexp=$curexp+$duration; ## New expiration
276 0         0 my $now=DateTime->now(time_zone => $curexp->time_zone()->name());
277 0         0 my $cmp=DateTime->compare($newexp,$now+$maxdelta);
278 0 0       0 return 2 unless ($cmp == -1); ## we must have : curexp+duration < now + maxdelta
279             }
280             }
281              
282 1         10 return 0; ## everything ok
283             }
284              
285             sub verify_duration_transfer
286             {
287 0     0 0 0 my ($self,$ndr,$duration,$domain,$op)=@_;
288              
289 0         0 return 0; ## everything ok
290             }
291              
292             ## A common case; we can not start a transfer, if domain name has already been transfered less than 15 days ago.
293             sub _verify_duration_transfer_15days
294             {
295 0     0   0 my ($self,$ndr,$duration,$domain,$op)=@_;
296              
297 0 0       0 return 0 unless ($op eq 'start'); ## we are not interested by other cases, they are always OK
298 0         0 my $rc=$self->domain_info($ndr,$domain,{hosts=>'none'});
299 0 0       0 return 1 unless ($rc->is_success());
300 0         0 my $trdate=$ndr->get_info('trDate');
301 0 0 0     0 return 0 unless ($trdate && $trdate->isa('DateTime'));
302              
303 0         0 my $now=DateTime->now(time_zone => $trdate->time_zone()->name());
304 0         0 my $cmp=DateTime->compare($now,$trdate+DateTime::Duration->new(days => 15));
305 0 0       0 return ($cmp == 1)? 0 : 1; ## we must have : now > transferdate + 15days
306             ## we return 0 if OK, anything else if not
307             }
308              
309             ####################################################################################################
310              
311             sub enforce_domain_name_constraints
312             {
313 8     8 0 10 my ($self,$ndr,$domain,$op)=@_;
314 8         22 my $err=$self->verify_name_domain($ndr,$domain,$op);
315 8 0 0     22 Net::DRI::Exception->die(0,'DRD',1,'Invalid domain name (error '.$err.'): '.((defined($domain) && $domain)? $domain : '?')) if length $err;
    50          
316 8         9 return;
317             }
318              
319             sub enforce_host_name_constraints
320             {
321 3     3 0 4 my ($self,$ndr,$dh,$checktld)=@_;
322 3         8 my $err=$self->verify_name_host($ndr,$dh,$checktld);
323 3 0       10 Net::DRI::Exception->die(0,'DRD',2,'Invalid host name (error '.$err.'): '.((Net::DRI::Util::is_class($dh,'Net::DRI::Data::Hosts'))? $dh->get_names(1) : (defined $dh? $dh : '?'))) if length $err;
    0          
    50          
324 3         3 return;
325             }
326              
327             sub err_invalid_contact
328             {
329 0     0 0 0 my ($self,$c)=@_;
330 0 0 0     0 Net::DRI::Exception->die(0,'DRD',6,'Invalid contact (should be a Contact object with a srid value): '.((defined $c && $c && eval { $c->can('srid'); } )? $c->srid() : '?'));
331 0         0 return;
332             }
333              
334             ####################################################################################################
335             ## Operations on DOMAINS
336             ####################################################################################################
337              
338             sub domain_create
339             {
340 1     1 0 2 my ($self,$ndr,$domain,$rd)=@_;
341 1         1 my @rs;
342              
343 1         121 $self->enforce_domain_name_constraints($ndr,$domain,'create');
344 1         3 $rd=Net::DRI::Util::create_params('domain_create',$rd);
345 1 50 33     4 my $pure=(Net::DRI::Util::has_key($rd,'pure_create') && $rd->{pure_create})? 1 : 0;
346 1         2 delete $rd->{pure_create};
347              
348 1 50       2 if (! $pure)
349             {
350 0         0 my $rs=$self->domain_check($ndr,$domain,$rd);
351 0         0 push @rs,$rs;
352 0 0 0     0 return Net::DRI::Util::link_rs(@rs) unless ($rs->is_success() && defined $rs->local_get_data('domain',$domain,'exist') && $rs->local_get_data('domain',$domain,'exist')==0);
      0        
353             }
354              
355 1         5 my $nsin=$ndr->local_object('hosts');
356 1         3 my $nsout=$ndr->local_object('hosts');
357 1 50       3 Net::DRI::Util::check_isa($rd->{ns},'Net::DRI::Data::Hosts') if Net::DRI::Util::has_key($rd,'ns'); ## test needed in both cases
358              
359             ## If not pure domain creation, separate nameservers (inside & outside of domain) and then create outside nameservers if needed
360 1 0 33     3 if (! $pure && exists $rd->{ns} && $self->has_object('ns'))
      0        
361             {
362 0         0 foreach my $i (1..$rd->{ns}->count())
363             {
364 0         0 my @a=$rd->{ns}->get_details($i);
365 0 0       0 if ($a[0]=~m/^(.+\.)?${domain}$/i)
366             {
367 0         0 $nsin->add(@a);
368             } else
369             {
370 0         0 my $ns=$ndr->local_object('hosts')->set(\@a);
371 0         0 my $e=$self->host_exist($ndr,$ns);
372 0 0 0     0 unless (defined $e && $e==1)
373             {
374 0         0 my $rs=$self->host_create($ndr,$ns);
375 0         0 push @rs,$rs;
376 0 0       0 return Net::DRI::Util::link_rs(@rs) unless $rs->is_success();
377             }
378 0         0 $nsout->add(@a);
379             }
380             }
381 0         0 $rd->{ns}=$nsout;
382             }
383              
384             ## If not pure domain creation, and if contacts are used make sure they exist as objects in the registry if needed
385 1 0 33     3 if (! $pure && exists $rd->{contact} && Net::DRI::Util::isa_contactset($rd->{contact}) && $self->has_object('contact'))
      0        
      0        
386             {
387 0         0 my %cd;
388 0         0 foreach my $t ($rd->{contact}->types())
389             {
390 0         0 foreach my $co ($rd->{contact}->get($t))
391             {
392 0 0       0 next if exists $cd{$co->srid()};
393 0         0 my $e=$self->contact_exist($ndr,$co);
394 0 0 0     0 unless (defined $e && $e==1)
395             {
396 0         0 my $rs=$self->contact_create($ndr,$co);
397 0         0 push @rs,$rs;
398 0 0       0 return Net::DRI::Util::link_rs(@rs) unless $rs->is_success();
399             }
400 0         0 $cd{$co->srid()}=1;
401             }
402             }
403             }
404              
405 1 50 33     3 Net::DRI::Exception->die(0,'DRD',3,'Invalid duration') if (Net::DRI::Util::has_key($rd,'duration') && ((ref $rd->{duration} ne 'DateTime::Duration') || $self->verify_duration_create($ndr,$rd->{duration},$domain)));
      33        
406 1         7 my $rs=$ndr->process('domain','create',[$domain,$rd]);
407 1 50       11 return $rs if $pure; ## pure domain creation we do not bother with other stuff and we stop here
408             ## From now on, we are sure $rs is defined
409 0         0 push @rs,$rs;
410 0 0       0 return Net::DRI::Util::link_rs(@rs) unless $rs->is_success();
411              
412             ## Create inside nameservers and add them to the domain
413 0 0       0 unless ($nsin->is_empty())
414             {
415 0         0 foreach my $i (1..$nsin->count())
416             {
417 0         0 my @a=$nsin->get_details($i);
418 0         0 my $ns=$ndr->local_object('hosts')->set(\@a);
419 0         0 my $rs=$self->host_create($ndr,$ns);
420 0         0 push @rs,$rs;
421 0 0       0 return Net::DRI::Util::link_rs(@rs) unless $rs->is_success();
422             }
423              
424 0 0       0 my $rs=$ndr->protocol_capable('domain_update','ns','add')? $self->domain_update_ns_add($ndr,$domain,$nsin) : $self->domain_update_ns_set($ndr,$domain,$nsin);
425 0         0 push @rs,$rs;
426 0 0       0 return Net::DRI::Util::link_rs(@rs) unless $rs->is_success();
427             }
428              
429             ## Add status to domain, if provided
430 0 0       0 if (Net::DRI::Util::has_key($rd,'status'))
431             {
432 0 0       0 my $rs=$ndr->protocol_capable('domain_update','status','add')? $self->domain_update_status_add($ndr,$domain,$rd->{status}) : $self->domain_update_status_set($ndr,$domain,$rd->{status});
433 0         0 push @rs,$rs;
434 0 0       0 return Net::DRI::Util::link_rs(@rs) unless $rs->is_success();
435             }
436              
437             ## Do a final info to populate the local cache
438 0 0       0 if ($ndr->protocol()->has_action('domain','info'))
439             {
440 0         0 my $rs=$self->domain_info($ndr,$domain);
441 0         0 push @rs,$rs;
442             }
443              
444 0         0 return Net::DRI::Util::link_rs(@rs);
445             }
446              
447             sub domain_delete
448             {
449 0     0 0 0 my ($self,$ndr,$domain,$rd)=@_;
450 0         0 $self->enforce_domain_name_constraints($ndr,$domain,'delete');
451 0         0 $rd=Net::DRI::Util::create_params('domain_delete',$rd);
452 0 0 0     0 my $pure=(Net::DRI::Util::has_key($rd,'pure_delete') && $rd->{pure_delete})? 1 : 0;
453 0         0 delete $rd->{pure_delete};
454              
455 0         0 my (@rs,$rs);
456              
457             ## This will make sure we get rid of in-bailiwick nameservers in some way, otherwise in their presence the domain delete would fail
458 0 0       0 if (! $pure)
459             {
460 0         0 $rs=$self->domain_info($ndr,$domain);
461 0         0 push @rs,$rs;
462 0 0       0 return Net::DRI::Util::link_rs(@rs) unless $rs->is_success();
463              
464             ## First remove all nameservers attached to domain name in case some of them are subordinates of the domain itself
465 0         0 my $ns=$ndr->get_info('ns');
466 0 0 0     0 if (defined $ns && !$ns->is_empty())
467             {
468 0         0 $rs=$self->domain_update_ns_del($ndr,$domain,$ns);
469 0         0 push @rs,$rs;
470 0 0       0 return Net::DRI::Util::link_rs(@rs) unless $rs->is_success();
471             }
472              
473             ## Now try to delete all subordinate hosts, or else (deletion will fail if hosts are used as nameservers for other domain names at registry) rename them somewhere if possible
474 0         0 $ns=$ndr->get_info('subordinate_hosts');
475 0 0 0     0 if (defined $ns && !$ns->is_empty() && $self->has_object('ns'))
      0        
476             {
477 0         0 my $base=$rd->{subordinate_rename};
478 0         0 foreach my $nsname ($ns->get_names())
479             {
480 0         0 $rs=$self->host_delete($ndr,$nsname);
481 0         0 push @rs,$rs;
482 0 0 0     0 return Net::DRI::Util::link_rs(@rs) unless ($rs->is_success() || ($rs->is('OBJECT_ASSOCIATION_PROHIBITS_OPERATION') && defined $base));
      0        
483 0 0       0 if (! $rs->is_success())
484             {
485 0         0 $rs=$self->host_update_name_set($ndr,$nsname.'.'.$base);
486 0         0 push @rs,$rs;
487 0 0       0 return Net::DRI::Util::link_rs(@rs) unless $rs->is_success();
488             }
489             }
490             }
491             }
492              
493 0         0 $rs=$ndr->process('domain','delete',[$domain,$rd]);
494 0         0 push @rs,$rs;
495 0         0 return Net::DRI::Util::link_rs(@rs);
496             }
497              
498             sub domain_info
499             {
500 1     1 0 2 my ($self,$ndr,$domain,$rd)=@_;
501 1         4 $self->enforce_domain_name_constraints($ndr,$domain,'info');
502 1         3 my $rc=$ndr->try_restore_from_cache('domain',$domain,'info');
503 1 50       4 if (! defined $rc)
504             {
505 1         3 $rd=Net::DRI::Util::create_params('domain_info',$rd);
506 1         3 $rc=$ndr->process('domain','info',[$domain,$rd]);
507             }
508 1         5 return $rc;
509             }
510              
511             sub domain_check
512             {
513 2     2 0 3 my ($self,$ndr,@p)=@_;
514 2         3 my (@names,$rd);
515 2         4 foreach my $p (@p)
516             {
517 2 50 33     11 if (defined $p && ref $p eq 'HASH')
518             {
519 0 0       0 Net::DRI::Exception::usererr_invalid_parameters('Only one optional ref hash with extra parameters is allowed in domain_check') if defined $rd;
520 0         0 $rd=Net::DRI::Util::create_params('domain_check',$p);
521 0         0 next;
522             }
523 2         4 $self->enforce_domain_name_constraints($ndr,$p,'check');
524 2         3 push @names,$p;
525             }
526 2 50       6 Net::DRI::Exception::usererr_insufficient_parameters('domain_check needs at least one domain name to check') unless @names;
527 2 50       4 $rd={} unless defined $rd;
528              
529 2         3 my (@rs,@todo);
530 0         0 my (%seendom,%seenrc);
531 2         2 foreach my $domain (@names)
532             {
533 2 50       5 next if exists $seendom{$domain};
534 2         3 $seendom{$domain}=1;
535 2         6 my $rs=$ndr->try_restore_from_cache('domain',$domain,'check');
536 2 50       4 if (! defined $rs)
537             {
538 2         3 push @todo,$domain;
539             } else
540             {
541 0 0       0 push @rs,$rs unless exists $seenrc{''.$rs}; ## Some ResultStatus may relate to multiple domain names (this is why we are doing this anyway !), so make sure not to use the same ResultStatus multiple times
542 0         0 $seenrc{''.$rs}=1;
543             }
544             }
545              
546 2 50       9 return Net::DRI::Util::link_rs(@rs) unless @todo;
547              
548 2 50 33     5 if (@todo > 1 && $ndr->protocol()->has_action('domain','check_multi'))
549             {
550 0         0 my $l=$self->info('check_limit');
551 0 0       0 if (! defined $l)
552             {
553 0         0 $ndr->log_output('notice','core','No check_limit specified in driver, assuming 10 for domain_check action. Please report if you know the correct value');
554 0         0 $l=10;
555             }
556 0         0 while (@todo)
557             {
558 0         0 my @lt=splice(@todo,0,$l);
559 0         0 push @rs,$ndr->process('domain','check_multi',[\@lt,$rd]);
560             }
561             } else ## either one domain only, or more than one but no check_multi available at protocol level
562             {
563 2         3 push @rs,map { $ndr->process('domain','check',[$_,$rd]); } @todo;
  2         7  
564             }
565              
566 2         7 return Net::DRI::Util::link_rs(@rs);
567             }
568              
569             sub domain_exist ## 1/0/undef
570             {
571 1     1 0 2 my ($self,$ndr,$domain,$rd)=@_;
572              
573 1 50       8 my $rc=$ndr->domain_check($domain,defined $rd ? $rd : ());
574 1 50       3 return unless $rc->is_success();
575 1         3 return $ndr->get_info('exist');
576             }
577              
578             sub domain_update
579             {
580 3     3 0 4 my ($self,$ndr,$domain,$tochange,$rd)=@_;
581 3         4 $self->enforce_domain_name_constraints($ndr,$domain,'update');
582 3         7 $rd=Net::DRI::Util::create_params('domain_update',$rd);
583 3         6 Net::DRI::Util::check_isa($tochange,'Net::DRI::Data::Changes');
584 3 50 33     7 Net::DRI::Exception->new(0,'DRD',4,'Registry does not handle contacts') if ($tochange->all_defined('contact') && ! $self->has_object('contact'));
585              
586 3         10 my $fp=$ndr->protocol->nameversion();
587 3         23 foreach my $t ($tochange->types())
588             {
589 3 50       7 Net::DRI::Exception->die(0,'DRD',5,'Protocol '.$fp.' is not capable of domain_update/'.$t) unless $ndr->protocol_capable('domain_update',$t);
590              
591 3         6 my $add=$tochange->add($t);
592 3         6 my $del=$tochange->del($t);
593 3         7 my $set=$tochange->set($t);
594              
595 3 50 66     8 Net::DRI::Exception->die(0,'DRD',5,'Protocol '.$fp.' is not capable of domain_update/'.$t.' (add)') if (defined($add) && ! $ndr->protocol_capable('domain_update',$t,'add'));
596 3 50 66     11 Net::DRI::Exception->die(0,'DRD',5,'Protocol '.$fp.' is not capable of domain_update/'.$t.' (del)') if (defined($del) && ! $ndr->protocol_capable('domain_update',$t,'del'));
597 3 50 33     8 Net::DRI::Exception->die(0,'DRD',5,'Protocol '.$fp.' is not capable of domain_update/'.$t.' (set)') if (defined($set) && ! $ndr->protocol_capable('domain_update',$t,'set'));
598             }
599              
600 3         5 foreach ($tochange->all_defined('ns')) { Net::DRI::Util::check_isa($_,'Net::DRI::Data::Hosts'); }
  4         7  
601 3         7 foreach ($tochange->all_defined('status')) { Net::DRI::Util::check_isa($_,'Net::DRI::Data::StatusList'); }
  0         0  
602 3         5 foreach ($tochange->all_defined('contact')) { Net::DRI::Util::check_isa($_,'Net::DRI::Data::ContactSet'); }
  0         0  
603              
604 3         8 my $rc=$ndr->process('domain','update',[$domain,$tochange,$rd]);
605 3         13 return $rc;
606             }
607              
608 1     1 0 2 sub domain_update_ns_add { my ($self,$ndr,$domain,$ns,$rd)=@_; return $self->domain_update_ns($ndr,$domain,$ns,$ndr->local_object('hosts'),$rd); }
  1         3  
609 1     1 0 2 sub domain_update_ns_del { my ($self,$ndr,$domain,$ns,$rd)=@_; return $self->domain_update_ns($ndr,$domain,$ndr->local_object('hosts'),$ns,$rd); }
  1         3  
610 0     0 0 0 sub domain_update_ns_set { my ($self,$ndr,$domain,$ns,$rd)=@_; return $self->domain_update_ns($ndr,$domain,$ns,undef,$rd); }
  0         0  
611              
612             sub domain_update_ns
613             {
614 3     3 0 3 my ($self,$ndr,$domain,$nsadd,$nsdel,$rd)=@_;
615 3         7 Net::DRI::Util::check_isa($nsadd,'Net::DRI::Data::Hosts');
616 3 50       5 if (defined($nsdel)) ## add + del
617             {
618 3         5 Net::DRI::Util::check_isa($nsdel,'Net::DRI::Data::Hosts');
619 3         6 my $c=$ndr->local_object('changes');
620 3 100       7 $c->add('ns',$nsadd) unless ($nsadd->is_empty());
621 3 100       4 $c->del('ns',$nsdel) unless ($nsdel->is_empty());
622 3         8 return $self->domain_update($ndr,$domain,$c,$rd);
623             } else
624             {
625 0         0 return $self->domain_update($ndr,$domain,$ndr->local_object('changes')->set('ns',$nsadd),$rd);
626             }
627             }
628              
629 0     0 0 0 sub domain_update_status_add { my ($self,$ndr,$domain,$s,$rd)=@_; return $self->domain_update_status($ndr,$domain,$s,$ndr->local_object('status'),$rd); }
  0         0  
630 0     0 0 0 sub domain_update_status_del { my ($self,$ndr,$domain,$s,$rd)=@_; return $self->domain_update_status($ndr,$domain,$ndr->local_object('status'),$s,$rd); }
  0         0  
631 0     0 0 0 sub domain_update_status_set { my ($self,$ndr,$domain,$s,$rd)=@_; return $self->domain_update_status($ndr,$domain,$s,undef,$rd); }
  0         0  
632              
633             sub domain_update_status
634             {
635 0     0 0 0 my ($self,$ndr,$domain,$sadd,$sdel,$rd)=@_;
636 0         0 Net::DRI::Util::check_isa($sadd,'Net::DRI::Data::StatusList');
637 0 0       0 if (defined($sdel)) ## add + del
638             {
639 0         0 Net::DRI::Util::check_isa($sdel,'Net::DRI::Data::StatusList');
640 0         0 my $c=$ndr->local_object('changes');
641 0 0       0 $c->add('status',$sadd) unless ($sadd->is_empty());
642 0 0       0 $c->del('status',$sdel) unless ($sdel->is_empty());
643 0         0 return $self->domain_update($ndr,$domain,$c,$rd);
644             } else
645             {
646 0         0 return $self->domain_update($ndr,$domain,$ndr->local_object('changes')->set('status',$sadd),$rd);
647             }
648             }
649              
650 0     0 0 0 sub domain_update_contact_add { my ($self,$ndr,$domain,$c,$rd)=@_; return $self->domain_update_contact($ndr,$domain,$c,$ndr->local_object('contactset'),$rd); }
  0         0  
651 0     0 0 0 sub domain_update_contact_del { my ($self,$ndr,$domain,$c,$rd)=@_; return $self->domain_update_contact($ndr,$domain,$ndr->local_object('contactset'),$c,$rd); }
  0         0  
652 0     0 0 0 sub domain_update_contact_set { my ($self,$ndr,$domain,$c,$rd)=@_; return $self->domain_update_contact($ndr,$domain,$c,undef,$rd); }
  0         0  
653              
654             sub domain_update_contact
655             {
656 0     0 0 0 my ($self,$ndr,$domain,$cadd,$cdel,$rd)=@_;
657 0         0 Net::DRI::Util::check_isa($cadd,'Net::DRI::Data::ContactSet');
658 0 0       0 if (defined($cdel)) ## add + del
659             {
660 0         0 Net::DRI::Util::check_isa($cdel,'Net::DRI::Data::ContactSet');
661 0         0 my $c=$ndr->local_object('changes');
662 0 0       0 $c->add('contact',$cadd) unless ($cadd->is_empty());
663 0 0       0 $c->del('contact',$cdel) unless ($cdel->is_empty());
664 0         0 return $self->domain_update($ndr,$domain,$c,$rd);
665             } else
666             {
667 0         0 return $self->domain_update($ndr,$domain,$ndr->local_object('changes')->set('contact',$cadd),$rd);
668             }
669             }
670              
671             sub domain_renew
672             {
673 1     1 0 2 my ($self,$ndr,$domain,$rd)=@_;
674              
675 1         10 $self->enforce_domain_name_constraints($ndr,$domain,'renew');
676 1         5 $rd=Net::DRI::Util::create_params('domain_renew',$rd);
677 1 50       4 Net::DRI::Util::check_isa($rd->{duration},'DateTime::Duration') if Net::DRI::Util::has_key($rd,'duration');
678 1 50       3 Net::DRI::Util::check_isa($rd->{current_expiration},'DateTime') if Net::DRI::Util::has_key($rd,'current_expiration');
679 1 50       7 Net::DRI::Exception->die(0,'DRD',3,'Invalid duration') if $self->verify_duration_renew($ndr,$rd->{duration},$domain,$rd->{current_expiration});
680              
681 1         7 return $ndr->process('domain','renew',[$domain,$rd]);
682             }
683              
684             sub domain_transfer
685             {
686 0     0 0 0 my ($self,$ndr,$domain,$op,$rd)=@_;
687              
688 0         0 $self->enforce_domain_name_constraints($ndr,$domain,'transfer');
689 0         0 $rd=Net::DRI::Util::create_params('domain_transfer',$rd);
690 0 0       0 Net::DRI::Exception::usererr_invalid_parameters('Transfer operation must be start,stop,accept,refuse or query') unless ($op=~m/^(?:start|stop|query|accept|refuse)$/);
691 0 0 0     0 Net::DRI::Exception->die(0,'DRD',3,'Invalid duration') if Net::DRI::Util::has_key($rd,'duration') && $self->verify_duration_transfer($ndr,$rd->{duration},$domain,$op);
692              
693 0         0 my $rc;
694 0 0       0 if ($op eq 'start')
    0          
    0          
695             {
696 0         0 $rc=$ndr->process('domain','transfer_request',[$domain,$rd]);
697             } elsif ($op eq 'stop')
698             {
699 0         0 $rc=$ndr->process('domain','transfer_cancel',[$domain,$rd]);
700             } elsif ($op eq 'query')
701             {
702 0         0 $rc=$ndr->process('domain','transfer_query',[$domain,$rd]);
703             } else ## accept/refuse
704             {
705 0 0       0 $rd->{approve}=($op eq 'accept')? 1 : 0;
706 0         0 $rc=$ndr->process('domain','transfer_answer',[$domain,$rd]);
707             }
708              
709 0         0 return $rc;
710             }
711              
712 0     0 0 0 sub domain_transfer_start { my ($self,$ndr,$domain,$rd)=@_; return $self->domain_transfer($ndr,$domain,'start',$rd); }
  0         0  
713 0     0 0 0 sub domain_transfer_stop { my ($self,$ndr,$domain,$rd)=@_; return $self->domain_transfer($ndr,$domain,'stop',$rd); }
  0         0  
714 0     0 0 0 sub domain_transfer_query { my ($self,$ndr,$domain,$rd)=@_; return $self->domain_transfer($ndr,$domain,'query',$rd); }
  0         0  
715 0     0 0 0 sub domain_transfer_accept { my ($self,$ndr,$domain,$rd)=@_; return $self->domain_transfer($ndr,$domain,'accept',$rd); }
  0         0  
716 0     0 0 0 sub domain_transfer_refuse { my ($self,$ndr,$domain,$rd)=@_; return $self->domain_transfer($ndr,$domain,'refuse',$rd); }
  0         0  
717              
718              
719             sub domain_can
720             {
721 0     0 0 0 my ($self,$ndr,$domain,$what,$rd)=@_;
722              
723 0         0 my $sok=$self->domain_status_allows($ndr,$domain,$what,$rd);
724 0 0       0 return 0 unless ($sok);
725              
726 0         0 my $ismine=$self->domain_is_mine($ndr,$domain,$rd);
727 0         0 my $n=$self->domain_operation_needs_is_mine($ndr,$domain,$what);
728 0 0       0 return unless (defined($n));
729 0 0 0     0 return ($ismine xor $n)? 0 : 1;
730             }
731              
732 0     0 0 0 sub domain_status_allows_delete { my ($self,$ndr,$domain,$rd)=@_; return $self->domain_status_allows($ndr,$domain,'delete',$rd); }
  0         0  
733 0     0 0 0 sub domain_status_allows_update { my ($self,$ndr,$domain,$rd)=@_; return $self->domain_status_allows($ndr,$domain,'update',$rd); }
  0         0  
734 0     0 0 0 sub domain_status_allows_transfer { my ($self,$ndr,$domain,$rd)=@_; return $self->domain_status_allows($ndr,$domain,'transfer',$rd); }
  0         0  
735 0     0 0 0 sub domain_status_allows_renew { my ($self,$ndr,$domain,$rd)=@_; return $self->domain_status_allows($ndr,$domain,'renew',$rd); }
  0         0  
736              
737             sub domain_status_allows
738             {
739 0     0 0 0 my ($self,$ndr,$domain,$what,$rd)=@_;
740              
741 0 0       0 return 0 unless ($what=~m/^(?:delete|update|transfer|renew)$/);
742 0         0 my $s=$self->domain_current_status($ndr,$domain,$rd);
743 0 0       0 return 0 unless defined $s;
744              
745 0 0       0 return $s->can_delete() if ($what eq 'delete');
746 0 0       0 return $s->can_update() if ($what eq 'update');
747 0 0       0 return $s->can_transfer() if ($what eq 'transfer');
748 0 0       0 return $s->can_renew() if ($what eq 'renew');
749 0         0 return 0; ## failsafe
750             }
751              
752             sub domain_current_status
753             {
754 0     0 0 0 my ($self,$ndr,$domain,$rd)=@_;
755 0         0 my $rc=$self->domain_info($ndr,$domain,$rd);
756 0 0       0 return unless $rc->is_success();
757 0         0 my $s=$ndr->get_info('status');
758 0 0       0 return unless Net::DRI::Util::isa_statuslist($s);
759 0         0 return $s;
760             }
761              
762             sub domain_is_mine
763             {
764 0     0 0 0 my ($self,$ndr,$domain,$rd)=@_;
765 0         0 my $clid=$self->info('client_id');
766 0 0       0 return unless defined $clid;
767 0         0 my $rc=$self->domain_info($ndr,$domain,$rd);
768 0 0       0 return unless $rc->is_success();
769 0         0 my $id=$ndr->get_info('clID');
770 0 0       0 return unless defined $id;
771 0 0       0 return ($clid=~m/^${id}$/)? 1 : 0;
772             }
773              
774             ####################################################################################################
775             ## Operations on HOSTS
776             ####################################################################################################
777              
778             sub host_create
779             {
780 0     0 0 0 my ($self,$ndr,$dh,$rh)=@_;
781 0         0 $rh=Net::DRI::Util::create_params('host_create',$rh);
782 0 0       0 my $name=Net::DRI::Util::isa_hosts('$dh')? $dh->get_details(1) : $dh;
783 0         0 $self->enforce_host_name_constraints($ndr,$name,0);
784              
785 0         0 my $rc=$ndr->process('host','create',[$dh,$rh]);
786 0         0 return $rc;
787             }
788              
789             sub host_delete
790             {
791 1     1 0 3 my ($self,$ndr,$dh,$rh)=@_;
792 1         3 $rh=Net::DRI::Util::create_params('host_delete',$rh);
793 1 50       12 my $name=Net::DRI::Util::isa_hosts('$dh')? $dh->get_details(1) : $dh;
794 1         3 $self->enforce_host_name_constraints($ndr,$name);
795              
796 1         5 my $rc=$ndr->process('host','delete',[$dh,$rh]);
797 1         6 return $rc;
798             }
799              
800             sub host_info
801             {
802 0     0 0 0 my ($self,$ndr,$dh,$rh)=@_;
803 0         0 $rh=Net::DRI::Util::create_params('host_info',$rh);
804 0 0       0 my $name=Net::DRI::Util::isa_hosts('$dh')? $dh->get_details(1) : $dh;
805 0         0 $self->enforce_host_name_constraints($ndr,$name);
806              
807 0         0 my $rc=$ndr->try_restore_from_cache('host',$name,'info');
808 0 0       0 if (! defined $rc) { $rc=$ndr->process('host','info',[$dh,$rh]); }
  0         0  
809              
810 0 0       0 return $rc unless $rc->is_success();
811 0 0       0 return (wantarray())? ($rc,$ndr->get_info('self')) : $rc;
812             }
813              
814             sub host_check
815             {
816 2     2 0 3 my ($self,$ndr,@p)=@_;
817 2         1 my (@names,$rd);
818 2 50 33     4 foreach my $p (map { defined && Net::DRI::Util::isa_hosts($_,1) ? $_->get_names() : $_ } @p)
  2         8  
819             {
820 2 50 33     8 if (defined $p && ref $p eq 'HASH')
821             {
822 0 0       0 Net::DRI::Exception::usererr_invalid_parameters('Only one optional ref hash with extra parameters is allowed in host_check') if defined $rd;
823 0         0 $rd=Net::DRI::Util::create_params('host_check',$p);
824 0         0 next;
825             }
826 2         6 $self->enforce_host_name_constraints($ndr,$p);
827 2         3 push @names,$p;
828             }
829 2 50       3 Net::DRI::Exception::usererr_insufficient_parameters('host_check needs at least one domain name to check') unless @names;
830 2 50       5 $rd={} unless defined $rd;
831              
832 2         2 my (@rs,@todo);
833 0         0 my (%seenhost,%seenrc);
834 2         3 foreach my $host (@names)
835             {
836 2 50       4 next if exists $seenhost{$host};
837 2         3 $seenhost{$host}=1;
838 2         9 my $rs=$ndr->try_restore_from_cache('host',$host,'check');
839 2 50       5 if (! defined $rs)
840             {
841 2         3 push @todo,$host;
842             } else
843             {
844 0 0       0 push @rs,$rs unless exists $seenrc{''.$rs}; ## Some ResultStatus may relate to multiple host names (this is why we are doing this anyway !), so make sure not to use the same ResultStatus multiple times
845 0         0 $seenrc{''.$rs}=1;
846             }
847             }
848              
849 2 50       5 return Net::DRI::Util::link_rs(@rs) unless @todo;
850              
851 2 50 33     9 if (@todo > 1 && $ndr->protocol()->has_action('host','check_multi'))
852             {
853 0         0 my $l=$self->info('check_limit');
854 0 0       0 if (! defined $l)
855             {
856 0         0 $ndr->log_output('notice','core','No check_limit specified in driver, assuming 10 for host_check action. Please report if you know the correct value');
857 0         0 $l=10;
858             }
859 0         0 while (@todo)
860             {
861 0         0 my @lt=splice(@todo,0,$l);
862 0         0 push @rs,$ndr->process('host','check_multi',[\@lt,$rd]);
863             }
864             } else ## either one domain only, or more than one but no check_multi available at protocol level
865             {
866 2         3 push @rs,map { $ndr->process('host','check',[$_,$rd]); } @todo;
  2         6  
867             }
868              
869 2         6 return Net::DRI::Util::link_rs(@rs);
870             }
871              
872             sub host_exist ## 1/0/undef
873             {
874 1     1 0 2 my ($self,$ndr,$dh,$rh)=@_;
875              
876 1 50       6 my $rc=$ndr->host_check($dh,defined $rh ? $rh : ());
877 1 50       3 return unless $rc->is_success();
878 1         2 return $ndr->get_info('exist');
879             }
880              
881             sub host_update
882             {
883 0     0 0   my ($self,$ndr,$dh,$tochange,$rh)=@_;
884 0           $rh=Net::DRI::Util::create_params('host_update',$rh);
885 0 0         my $name=Net::DRI::Util::isa_hosts('$dh')? $dh->get_details(1) : $dh;
886 0           $self->enforce_host_name_constraints($ndr,$name);
887 0           Net::DRI::Util::check_isa($tochange,'Net::DRI::Data::Changes');
888              
889 0           my $fp=$ndr->protocol->nameversion();
890 0           foreach my $t ($tochange->types())
891             {
892 0 0         Net::DRI::Exception->die(0,'DRD',5,'Protocol '.$fp.' is not capable of host_update/'.$t) unless $ndr->protocol_capable('host_update',$t);
893              
894 0           my $add=$tochange->add($t);
895 0           my $del=$tochange->del($t);
896 0           my $set=$tochange->set($t);
897              
898 0 0 0       Net::DRI::Exception->die(0,'DRD',5,'Protocol '.$fp.' is not capable of host_update/'.$t.' (add)') if (defined($add) && ! $ndr->protocol_capable('host_update',$t,'add'));
899 0 0 0       Net::DRI::Exception->die(0,'DRD',5,'Protocol '.$fp.' is not capable of host_update/'.$t.' (del)') if (defined($del) && ! $ndr->protocol_capable('host_update',$t,'del'));
900 0 0 0       Net::DRI::Exception->die(0,'DRD',5,'Protocol '.$fp.' is not capable of host_update/'.$t.' (set)') if (defined($set) && ! $ndr->protocol_capable('host_update',$t,'set'));
901             }
902              
903 0           foreach ($tochange->all_defined('ip')) { Net::DRI::Util::check_isa($_,'Net::DRI::Data::Hosts'); }
  0            
904 0           foreach ($tochange->all_defined('status')) { Net::DRI::Util::check_isa($_,'Net::DRI::Data::StatusList'); }
  0            
905 0           foreach ($tochange->all_defined('name')) { $self->enforce_host_name_constraints($ndr,$_); }
  0            
906              
907 0           my $rc=$ndr->process('host','update',[$dh,$tochange,$rh]);
908 0           return $rc;
909             }
910              
911 0     0 0   sub host_update_ip_add { my ($self,$ndr,$dh,$ip,$rh)=@_; return $self->host_update_ip($ndr,$dh,$ip,$ndr->local_object('hosts'),$rh); }
  0            
912 0     0 0   sub host_update_ip_del { my ($self,$ndr,$dh,$ip,$rh)=@_; return $self->host_update_ip($ndr,$dh,$ndr->local_object('hosts'),$ip,$rh); }
  0            
913 0     0 0   sub host_update_ip_set { my ($self,$ndr,$dh,$ip,$rh)=@_; return $self->host_update_ip($ndr,$dh,$ip,undef,$rh); }
  0            
914              
915             sub host_update_ip
916             {
917 0     0 0   my ($self,$ndr,$dh,$ipadd,$ipdel,$rh)=@_;
918 0           Net::DRI::Util::check_isa($ipadd,'Net::DRI::Data::Hosts');
919 0 0         if (defined($ipdel)) ## add + del
920             {
921 0           Net::DRI::Util::check_isa($ipdel,'Net::DRI::Data::Hosts');
922 0           my $c=$ndr->local_object('changes');
923 0 0         $c->add('ip',$ipadd) unless ($ipadd->is_empty());
924 0 0         $c->del('ip',$ipdel) unless ($ipdel->is_empty());
925 0           return $self->host_update($ndr,$dh,$c,$rh);
926             } else ## just set
927             {
928 0           return $self->host_update($ndr,$dh,$ndr->local_object('changes')->set('ip',$ipadd),$rh);
929             }
930             }
931              
932 0     0 0   sub host_update_status_add { my ($self,$ndr,$dh,$s,$rh)=@_; return $self->host_update_status($ndr,$dh,$s,$ndr->local_object('status'),$rh); }
  0            
933 0     0 0   sub host_update_status_del { my ($self,$ndr,$dh,$s,$rh)=@_; return $self->host_update_status($ndr,$dh,$ndr->local_object('status'),$s,$rh); }
  0            
934 0     0 0   sub host_update_status_set { my ($self,$ndr,$dh,$s,$rh)=@_; return $self->host_update_status($ndr,$dh,$s,undef,$rh); }
  0            
935              
936             sub host_update_status
937             {
938 0     0 0   my ($self,$ndr,$dh,$sadd,$sdel,$rh)=@_;
939 0           Net::DRI::Util::check_isa($sadd,'Net::DRI::Data::StatusList');
940 0 0         if (defined($sdel)) ## add + del
941             {
942 0           Net::DRI::Util::check_isa($sdel,'Net::DRI::Data::StatusList');
943 0           my $c=$ndr->local_object('changes');
944 0 0         $c->add('status',$sadd) unless ($sadd->is_empty());
945 0 0         $c->del('status',$sdel) unless ($sdel->is_empty());
946 0           return $self->host_update($ndr,$dh,$c,$rh);
947             } else ## just set
948             {
949 0           return $self->host_update($ndr,$dh,$ndr->local_object('changes')->set('status',$sadd),$rh);
950             }
951             }
952              
953             sub host_update_name_set
954             {
955 0     0 0   my ($self,$ndr,$dh,$newname,$rh)=@_;
956 0 0 0       $newname=$newname->get_names(1) if ($newname && Net::DRI::Util::is_class($newname,'Net::DRI::Data::Hosts'));
957 0           $self->enforce_host_name_constraints($ndr,$newname);
958 0           return $self->host_update($ndr,$dh,$ndr->local_object('changes')->set('name',$newname),$rh);
959             }
960              
961             sub host_current_status
962             {
963 0     0 0   my ($self,$ndr,$dh,$rh)=@_;
964 0           my $rc=$self->host_info($ndr,$dh,$rh);
965 0 0         return unless $rc->is_success();
966 0           my $s=$ndr->get_info('status');
967 0 0         return unless Net::DRI::Util::isa_statuslist($s);
968 0           return $s;
969             }
970              
971             sub host_is_mine
972             {
973 0     0 0   my ($self,$ndr,$dh,$rh)=@_;
974 0           my $clid=$self->info('client_id');
975 0 0         return unless defined $clid;
976 0           my $rc=$self->host_info($ndr,$dh,$rh);
977 0 0         return unless $rc->is_success();
978 0           my $id=$ndr->get_info('clID');
979 0 0         return unless defined $id;
980 0 0         return ($clid=~m/^${id}$/)? 1 : 0;
981             }
982              
983             ####################################################################################################
984             ## Operations on CONTACTS
985             ####################################################################################################
986              
987             sub contact_create
988             {
989 0     0 0   my ($self,$ndr,$contact,$ep)=@_;
990 0 0         $self->err_invalid_contact($contact) unless Net::DRI::Util::isa_contact($contact);
991 0           $ep=Net::DRI::Util::create_params('contact_create',$ep);
992 0 0         $contact->init('create',$ndr) if $contact->can('init');
993 0           $contact->validate(); ## will trigger an Exception if validation not ok
994 0           my $rc=$ndr->process('contact','create',[$contact,$ep]);
995 0           return $rc;
996             }
997              
998             sub contact_delete
999             {
1000 0     0 0   my ($self,$ndr,$contact,$ep)=@_;
1001 0 0 0       $self->err_invalid_contact($contact) unless (Net::DRI::Util::isa_contact($contact) && $contact->srid());
1002 0           $ep=Net::DRI::Util::create_params('contact_delete',$ep);
1003 0           my $rc=$ndr->process('contact','delete',[$contact,$ep]);
1004 0           return $rc;
1005             }
1006              
1007             sub contact_info
1008             {
1009 0     0 0   my ($self,$ndr,$contact,$ep)=@_;
1010 0 0 0       $self->err_invalid_contact($contact) unless (Net::DRI::Util::isa_contact($contact) && $contact->srid());
1011 0           $ep=Net::DRI::Util::create_params('contact_info',$ep);
1012 0           my $rc=$ndr->try_restore_from_cache('contact',$contact->srid(),'info');
1013 0 0         if (! defined $rc) { $rc=$ndr->process('contact','info',[$contact,$ep]); }
  0            
1014 0           return $rc;
1015             }
1016              
1017             sub contact_check
1018             {
1019 0     0 0   my ($self,$ndr,@p)=@_;
1020 0           my (@names,$rd);
1021 0           foreach my $p (@p)
1022             {
1023 0 0 0       if (defined $p && ref $p eq 'HASH')
1024             {
1025 0 0         Net::DRI::Exception::usererr_invalid_parameters('Only one optional ref hash with extra parameters is allowed in contact_check') if defined $rd;
1026 0           $rd=Net::DRI::Util::create_params('contact_check',$p);
1027 0           next;
1028             }
1029 0 0 0       $self->err_invalid_contact($p) unless (Net::DRI::Util::isa_contact($p) && length $p->srid());
1030 0           push @names,$p;
1031             }
1032 0 0         Net::DRI::Exception::usererr_insufficient_parameters('contact_check needs at least one domain name to check') unless @names;
1033 0 0         $rd={} unless defined $rd;
1034              
1035 0           my (@rs,@todo);
1036 0           my (%seencon,%seenrc);
1037 0           foreach my $contact (@names)
1038             {
1039 0 0         next if exists $seencon{$contact};
1040 0           $seencon{$contact}=1;
1041 0           my $rs=$ndr->try_restore_from_cache('contact',$contact->srid(),'check');
1042 0 0         if (! defined $rs)
1043             {
1044 0           push @todo,$contact;
1045             } else
1046             {
1047 0 0         push @rs,$rs unless exists $seenrc{''.$rs}; ## Some ResultStatus may relate to multiple contact names (this is why we are doing this anyway !), so make sure not to use the same ResultStatus multiple times
1048 0           $seenrc{''.$rs}=1;
1049             }
1050             }
1051              
1052 0 0         return Net::DRI::Util::link_rs(@rs) unless @todo;
1053              
1054 0 0 0       if (@todo > 1 && $ndr->protocol()->has_action('contact','check_multi'))
1055             {
1056 0           my $l=$self->info('check_limit');
1057 0 0         if (! defined $l)
1058             {
1059 0           $ndr->log_output('notice','core','No check_limit specified in driver, assuming 10 for contact_check action. Please report if you know the correct value');
1060 0           $l=10;
1061             }
1062 0           while (@todo)
1063             {
1064 0           my @lt=splice(@todo,0,$l);
1065 0           push @rs,$ndr->process('contact','check_multi',[\@lt,$rd]);
1066             }
1067             } else ## either one domain only, or more than one but no check_multi available at protocol level
1068             {
1069 0           push @rs,map { $ndr->process('contact','check',[$_,$rd]); } @todo;
  0            
1070             }
1071              
1072 0           return Net::DRI::Util::link_rs(@rs);
1073             }
1074              
1075             sub contact_exist ## 1/0/undef
1076             {
1077 0     0 0   my ($self,$ndr,$contact,$ep)=@_;
1078 0 0 0       $self->err_invalid_contact($contact) unless (Net::DRI::Util::isa_contact($contact) && $contact->srid());
1079              
1080 0 0         my $rc=$ndr->contact_check($contact,defined $ep ? $ep : ());
1081 0 0         return unless $rc->is_success();
1082 0           return $ndr->get_info('exist');
1083             }
1084              
1085             sub contact_update
1086             {
1087 0     0 0   my ($self,$ndr,$contact,$tochange,$ep)=@_;
1088 0 0 0       $self->err_invalid_contact($contact) unless (Net::DRI::Util::isa_contact($contact) && $contact->srid());
1089 0           Net::DRI::Util::check_isa($tochange,'Net::DRI::Data::Changes');
1090 0           $ep=Net::DRI::Util::create_params('contact_update',$ep);
1091              
1092 0           my $fp=$ndr->protocol->nameversion();
1093 0           foreach my $t ($tochange->types())
1094             {
1095 0 0         Net::DRI::Exception->die(0,'DRD',5,'Protocol '.$fp.' is not capable of contact_update/'.$t) unless $ndr->protocol_capable('contact_update',$t);
1096              
1097 0           my $add=$tochange->add($t);
1098 0           my $del=$tochange->del($t);
1099 0           my $set=$tochange->set($t);
1100              
1101 0 0 0       Net::DRI::Exception->die(0,'DRD',5,'Protocol '.$fp.' is not capable of contact_update/'.$t.' (add)') if (defined($add) && ! $ndr->protocol_capable('contact_update',$t,'add'));
1102 0 0 0       Net::DRI::Exception->die(0,'DRD',5,'Protocol '.$fp.' is not capable of contact_update/'.$t.' (del)') if (defined($del) && ! $ndr->protocol_capable('contact_update',$t,'del'));
1103 0 0 0       Net::DRI::Exception->die(0,'DRD',5,'Protocol '.$fp.' is not capable of contact_update/'.$t.' (set)') if (defined($set) && ! $ndr->protocol_capable('contact_update',$t,'set'));
1104             }
1105              
1106 0           foreach ($tochange->all_defined('status')) { Net::DRI::Util::check_isa($_,'Net::DRI::Data::StatusList'); }
  0            
1107              
1108 0           my $rc=$ndr->process('contact','update',[$contact,$tochange,$ep]);
1109 0           return $rc;
1110             }
1111              
1112 0     0 0   sub contact_update_status_add { my ($self,$ndr,$contact,$s,$ep)=@_; return $self->contact_update_status($ndr,$contact,$s,$ndr->local_object('status'),$ep); }
  0            
1113 0     0 0   sub contact_update_status_del { my ($self,$ndr,$contact,$s,$ep)=@_; return $self->contact_update_status($ndr,$contact,$ndr->local_object('status'),$s,$ep); }
  0            
1114 0     0 0   sub contact_update_status_set { my ($self,$ndr,$contact,$s,$ep)=@_; return $self->contact_update_status($ndr,$contact,$s,undef,$ep); }
  0            
1115              
1116             sub contact_update_status
1117             {
1118 0     0 0   my ($self,$ndr,$contact,$sadd,$sdel,$ep)=@_;
1119 0           Net::DRI::Util::check_isa($sadd,'Net::DRI::Data::StatusList');
1120 0 0         if (defined($sdel)) ## add + del
1121             {
1122 0           Net::DRI::Util::check_isa($sdel,'Net::DRI::Data::StatusList');
1123 0           my $c=$ndr->local_object('changes');
1124 0 0         $c->add('status',$sadd) unless ($sadd->is_empty());
1125 0 0         $c->del('status',$sdel) unless ($sdel->is_empty());
1126 0           return $self->contact_update($ndr,$contact,$c,$ep);
1127             } else
1128             {
1129 0           return $self->contact_update($ndr,$contact,$ndr->local_object('changes')->set('status',$sadd),$ep);
1130             }
1131             }
1132              
1133             sub contact_transfer
1134             {
1135 0     0 0   my ($self,$ndr,$contact,$op,$ep)=@_;
1136 0 0 0       $self->err_invalid_contact($contact) unless (Net::DRI::Util::isa_contact($contact) && $contact->srid());
1137 0 0         Net::DRI::Exception::usererr_invalid_parameters('Transfer operation must be start,stop,accept,refuse or query') unless ($op=~m/^(?:start|stop|query|accept|refuse)$/);
1138 0           $ep=Net::DRI::Util::create_params('contact_transfer',$ep);
1139              
1140 0           my $rc;
1141 0 0         if ($op eq 'start')
    0          
    0          
1142             {
1143 0           $rc=$ndr->process('contact','transfer_request',[$contact,$ep]);
1144             } elsif ($op eq 'stop')
1145             {
1146 0           $rc=$ndr->process('contact','transfer_cancel',[$contact,$ep]);
1147             } elsif ($op eq 'query')
1148             {
1149 0           $rc=$ndr->process('contact','transfer_query',[$contact,$ep]);
1150             } else ## accept/refuse
1151             {
1152 0 0         $ep->{approve}=($op eq 'accept')? 1 : 0;
1153 0           $rc=$ndr->process('contact','transfer_answer',[$contact,$ep]);
1154             }
1155              
1156 0           return $rc;
1157             }
1158              
1159 0     0 0   sub contact_transfer_start { my ($self,$ndr,$contact,$ep)=@_; return $self->contact_transfer($ndr,$contact,'start',$ep); }
  0            
1160 0     0 0   sub contact_transfer_stop { my ($self,$ndr,$contact,$ep)=@_; return $self->contact_transfer($ndr,$contact,'stop',$ep); }
  0            
1161 0     0 0   sub contact_transfer_query { my ($self,$ndr,$contact,$ep)=@_; return $self->contact_transfer($ndr,$contact,'query',$ep); }
  0            
1162 0     0 0   sub contact_transfer_accept { my ($self,$ndr,$contact,$ep)=@_; return $self->contact_transfer($ndr,$contact,'accept',$ep); }
  0            
1163 0     0 0   sub contact_transfer_refuse { my ($self,$ndr,$contact,$ep)=@_; return $self->contact_transfer($ndr,$contact,'refuse',$ep); }
  0            
1164              
1165             sub contact_current_status
1166             {
1167 0     0 0   my ($self,$ndr,$contact,$ep)=@_;
1168 0           my $rc=$self->contact_info($ndr,$contact,$ep);
1169 0 0         return unless $rc->is_success();
1170 0           my $s=$ndr->get_info('status');
1171 0 0         return unless Net::DRI::Util::isa_statuslist($s);
1172 0           return $s;
1173             }
1174              
1175             sub contact_is_mine
1176             {
1177 0     0 0   my ($self,$ndr,$contact,$ep)=@_;
1178 0           my $clid=$self->info('client_id');
1179 0 0         return unless defined $clid;
1180 0           my $rc=$self->contact_info($ndr,$contact,$ep);
1181 0 0         return unless $rc->is_success();
1182 0           my $id=$ndr->get_info('clID');
1183 0 0         return unless defined $id;
1184 0 0         return ($clid=~m/^${id}$/)? 1 : 0;
1185             }
1186              
1187             ####################################################################################################
1188             ## Message commands (like POLL in EPP)
1189             ####################################################################################################
1190              
1191             sub message_retrieve
1192             {
1193 0     0 0   my ($self,$ndr,$id)=@_;
1194 0           my $rc=$ndr->process('message','retrieve',[$id]);
1195 0           return $rc;
1196             }
1197              
1198             sub message_delete
1199             {
1200 0     0 0   my ($self,$ndr,$id)=@_;
1201 0           my $rc=$ndr->process('message','delete',[$id]);
1202 0           return $rc;
1203             }
1204              
1205             sub message_waiting
1206             {
1207 0     0 0   my ($self,$ndr)=@_;
1208 0           my $c=$self->message_count($ndr);
1209 0 0 0       return (defined($c) && $c)? 1 : 0;
1210             }
1211              
1212             sub message_count
1213             {
1214 0     0 0   my ($self,$ndr)=@_;
1215 0           my $count=$ndr->get_info('count','message','info');
1216 0 0         return $count if defined($count);
1217 0           my $rc=$ndr->process('message','retrieve');
1218 0 0         return unless $rc->is_success();
1219 0           $count=$ndr->get_info('count','message','info');
1220 0 0 0       return (defined($count) && $count)? $count : 0;
1221             }
1222              
1223             ####################################################################################################
1224             ## Extensions commands used by at least 2 DRDs so factorized here
1225             ## TODO: for now, this is kind of contradictory with make_exception_for_unavailable_operations()
1226             ## this whole part would need to be redefined, see TODO file
1227             ####################################################################################################
1228              
1229             ## For AFNIC ARNES (subclassed) BE EURid LU
1230             sub domain_trade_start
1231             {
1232 0     0 0   my ($self,$ndr,$domain,$rd)=@_;
1233 0           $self->enforce_domain_name_constraints($ndr,$domain,'trade');
1234 0           return $ndr->process('domain','trade_request',[$domain,$rd]);
1235             }
1236              
1237             ## For AFNIC LU
1238             sub domain_trade_query
1239             {
1240 0     0 0   my ($self,$ndr,$domain,$rd)=@_;
1241 0           $self->enforce_domain_name_constraints($ndr,$domain,'trade');
1242 0           return $ndr->process('domain','trade_query',[$domain,$rd]);
1243             }
1244              
1245             ## For AFNIC EURid LU
1246             sub domain_trade_stop
1247             {
1248 0     0 0   my ($self,$ndr,$domain,$rd)=@_;
1249 0           $self->enforce_domain_name_constraints($ndr,$domain,'trade');
1250 0           return $ndr->process('domain','trade_cancel',[$domain,$rd]);
1251             }
1252              
1253             ## Used by AT & NO but not with same EPP command name => impossible to factorize here
1254             ##sub domain_withdraw
1255             ##sub domain_transfer_execute
1256              
1257             ## For BE EURid SIDN (subclassed)
1258             sub domain_undelete
1259             {
1260 0     0 0   my ($self,$ndr,$domain,$rd)=@_;
1261 0           $self->enforce_domain_name_constraints($ndr,$domain,'undelete');
1262 0           return $ndr->process('domain','undelete',[$domain,$rd]);
1263             }
1264              
1265             ## For BE EUrid
1266             sub domain_reactivate
1267             {
1268 0     0 0   my ($self,$ndr,$domain,$rd)=@_;
1269 0           $self->enforce_domain_name_constraints($ndr,$domain,'reactivate');
1270 0           return $ndr->process('domain','reactivate',[$domain,$rd]);
1271             }
1272              
1273             ## For BE EURid
1274             ## (no _stop in BE ?)
1275             sub domain_transfer_quarantine
1276             {
1277 0     0 0   my ($self,$ndr,$domain,$op,$rd)=@_;
1278 0           $self->enforce_domain_name_constraints($ndr,$domain,'transfer_quarantine');
1279 0 0         Net::DRI::Exception::usererr_invalid_parameters('Transfer from quarantine operation must be start or stop') unless ($op=~m/^(?:start|stop)$/);
1280              
1281 0           my $rc;
1282 0 0         if ($op eq 'start')
    0          
1283             {
1284 0           $rc=$ndr->process('domain','transferq_request',[$domain,$rd]);
1285             } elsif ($op eq 'stop')
1286             {
1287 0           $rc=$ndr->process('domain','transferq_cancel',[$domain,$rd]);
1288             }
1289 0           return $rc;
1290             }
1291              
1292 0     0 0   sub domain_transfer_quarantine_start { my ($self,$ndr,$domain,$rd)=@_; return $self->domain_transfer_quarantine($ndr,$domain,'start',$rd); }
  0            
1293 0     0 0   sub domain_transfer_quarantine_stop { my ($self,$ndr,$domain,$rd)=@_; return $self->domain_transfer_quarantine($ndr,$domain,'stop',$rd); }
  0            
1294              
1295             ## nsgroup_* + keygroup_*
1296             ## For BE EUrid
1297             sub nsgroup_create
1298             {
1299 0     0 0   my ($self,$ndr,$nsg)=@_;
1300 0 0         Net::DRI::Exception::usererr_insufficient_parameters('nsgroup_create needs an hosts object') unless defined Net::DRI::Util::isa_nsgroup($nsg);
1301 0           return $ndr->process('nsgroup','create',[$nsg]);
1302             }
1303              
1304             sub nsgroup_delete
1305             {
1306 0     0 0   my ($self,$ndr,$nsg)=@_;
1307 0 0         Net::DRI::Exception::usererr_insufficient_parameters('nsgroup_delete needs an hosts object') unless defined Net::DRI::Util::isa_nsgroup($nsg);
1308 0           return $ndr->process('nsgroup','delete',[$nsg]);
1309             }
1310              
1311             sub nsgroup_check
1312             {
1313 0     0 0   my ($self,$ndr,@nsg)=@_;
1314 0 0         Net::DRI::Exception::usererr_insufficient_parameters('nsgroup_check needs at least an hosts object') unless grep { defined Net::DRI::Util::isa_nsgroup($_) } @nsg;
  0            
1315 0           return $ndr->process('nsgroup','check',[@nsg]);
1316             }
1317              
1318             sub nsgroup_info
1319             {
1320 0     0 0   my ($self,$ndr,$nsg)=@_;
1321 0 0         Net::DRI::Exception::usererr_insufficient_parameters('nsgroup_info needs an hosts object') unless defined Net::DRI::Util::isa_nsgroup($nsg);
1322 0           return $ndr->process('nsgroup','info',[$nsg]);
1323             }
1324              
1325             sub nsgroup_update
1326             {
1327 0     0 0   my ($self,$ndr,$nsg,$tochange)=@_;
1328 0 0         Net::DRI::Exception::usererr_insufficient_parameters('nsgroup_update needs an hosts object') unless defined Net::DRI::Util::isa_nsgroup($nsg);
1329 0           Net::DRI::Util::check_isa($tochange,'Net::DRI::Data::Changes');
1330 0           return $ndr->process('nsgroup','update',[$nsg,$tochange]);
1331             }
1332              
1333             sub keygroup_create
1334             {
1335 0     0 0   my ($self,$ndr,$kg,$rd)=@_;
1336 0 0         Net::DRI::Exception::usererr_insufficient_parameters('keygroup_create needs a keygroup name') unless defined $kg;
1337 0           return $ndr->process('keygroup','create',[$kg,$rd]);
1338             }
1339              
1340             sub keygroup_delete
1341             {
1342 0     0 0   my ($self,$ndr,$kg,$rd)=@_;
1343 0 0         Net::DRI::Exception::usererr_insufficient_parameters('keygroup_delete needs a keygroup name') unless defined $kg;
1344 0           return $ndr->process('keygroup','delete',[$kg,$rd]);
1345             }
1346              
1347             sub keygroup_check
1348             {
1349 0     0 0   my ($self,$ndr,@kgs)=@_;
1350 0 0 0       my $rd=(@kgs && ref $kgs[-1] eq 'HASH')? pop(@kgs) : {};
1351 0 0         Net::DRI::Exception::usererr_insufficient_parameters('keygroup_check needs at least a keygroup name') unless grep { defined } @kgs;
  0            
1352 0           return $ndr->process('keygroup','check',[\@kgs,$rd]);
1353             }
1354              
1355             sub keygroup_info
1356             {
1357 0     0 0   my ($self,$ndr,$kg,$rd)=@_;
1358 0 0         Net::DRI::Exception::usererr_insufficient_parameters('keygroup_info needs a keygroup name') unless defined $kg;
1359 0           return $ndr->process('keygroup','info',[$kg,$rd]);
1360             }
1361              
1362             sub keygroup_update
1363             {
1364 0     0 0   my ($self,$ndr,$kg,$tochange,$rd)=@_;
1365 0 0         Net::DRI::Exception::usererr_insufficient_parameters('keygroup_update needs a keygroup name') unless defined $kg;
1366 0           Net::DRI::Util::check_isa($tochange,'Net::DRI::Data::Changes');
1367 0           return $ndr->process('keygroup','update',[$kg,$tochange,$rd]);
1368             }
1369              
1370             # For BookMyName Gandi OVH
1371              
1372             sub account_list_domains
1373             {
1374 0     0 0   my ($self,$ndr)=@_;
1375 0           my $rc=$ndr->try_restore_from_cache('account','domains','list');
1376 0 0         if (! defined $rc) { $rc=$ndr->process('account','list_domains'); }
  0            
1377 0           return $rc;
1378             }
1379              
1380             ####################################################################################################
1381             # Misc
1382             ####################################################################################################
1383              
1384             sub ping
1385             {
1386 0     0 0   my ($self,$ndr,$reconnect)=@_;
1387 0           my ($po,$to)=$ndr->protocol_transport();
1388              
1389 0           my $rc=$to->ping({protocol=>$po},$reconnect); ## this can die
1390 0           return $rc;
1391             }
1392              
1393             sub raw_command
1394             {
1395 0     0 0   my ($self,$ndr,$cmd)=@_;
1396              
1397 0           my ($po,$to)=$ndr->protocol_transport();
1398 0           my $trid=$ndr->generate_trid();
1399 0           my $ctx={trid => $trid, otype => 'raw', oaction => 'command', phase => 'active' };
1400 0           my $count=1;
1401              
1402 0           my $tosend=Net::DRI::Data::Raw->new_from_string($cmd);
1403 0           $to->send($ctx,$tosend,$count,[]);
1404 0           my $res=$to->receive($ctx,$count);
1405 0           return $res->as_string();
1406             }
1407              
1408             ####################################################################################################
1409             1;