File Coverage

blib/lib/Net/EPP/Registry/Nominet.pm
Criterion Covered Total %
statement 59 769 7.6
branch 15 302 4.9
condition 6 104 5.7
subroutine 12 53 22.6
pod 5 30 16.6
total 97 1258 7.7


line stmt bran cond sub pod time code
1             #
2             # This program is free software; you can redistribute it and/or modify
3             # it under the terms of the GNU General Public License as published by
4             # the Free Software Foundation; either version 2 of the License, or
5             # (at your option) any later version.
6             #
7             # This program is distributed in the hope that it will be useful,
8             # but WITHOUT ANY WARRANTY; without even the implied warranty of
9             # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
10             # GNU General Public License for more details.
11             #
12             # You should have received a copy of the GNU General Public License
13             # along with this program; if not, write to the Free Software
14             # Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
15             #
16             ################################################################################
17             package Net::EPP::Registry::Nominet;
18              
19 11     11   1216835 use strict;
  11         111  
  11         328  
20 11     11   64 use warnings;
  11         19  
  11         282  
21              
22             # use other modules
23 11     11   5361 use Net::EPP::Frame;
  11         991074  
  11         401  
24 11     11   96 use Carp;
  11         26  
  11         651  
25              
26 11     11   80 use base qw(Net::EPP::Simple);
  11         23  
  11         7701  
27 11     11   1037146 use constant EPP_XMLNS => 'urn:ietf:params:xml:ns:epp-1.0';
  11         35  
  11         676  
28 11     11   108 use vars qw($Error $Code $Message);
  11         34  
  11         742  
29              
30             BEGIN {
31 11     11   97803 our $VERSION = '0.07_03';
32             }
33              
34             # file-scoped lexicals
35             my %Host = (
36             prod => 'epp.nominet.org.uk',
37             test => 'testbed-epp.nominet.org.uk',
38             ote => 'ote-epp.nominet.org.uk',
39             );
40             my $EPPVer = '1.0';
41             my $EPPLang = 'en';
42             my $NSVer = '2.0';
43             my $Debug = 0;
44              
45             =pod
46              
47             =head1 Name
48              
49             Net::EPP::Registry::Nominet - a simple client interface to the Nominet EPP
50             service
51              
52             =head1 Synopsis
53              
54             use strict;
55             use warnings;
56             use Net::EPP::Registry::Nominet;
57              
58             my $epp = Net::EPP::Registry::Nominet->new (
59             user => 'MYTAG',
60             pass => 'mypass'
61             ) or die ('Could not login to EPP server: ', $Net::EPP::Registry::Nominet::Message);
62              
63             my $dom = 'foo.co.uk';
64            
65             if ($epp->check_domain($dom) == 1) {
66             print "Domain $dom is available\n" ;
67             } else {
68             my $info = $epp->domain_info($dom);
69             my $res = $epp->renew_domain ({
70             name => $dom,
71             cur_exp_date => $info->{exDate},
72             period => 5
73             });
74             if ($res) {
75             print "$dom renewed; new expiry date is $res\n";
76             } else {
77             warn "Unable to renew $dom: " . $epp->get_reason;
78             }
79             }
80              
81             =head1 Description
82              
83             L is the organisation in charge of
84             domain names under the .uk TLD. Historically it used cryptographically
85             signed email communications with registrars to provision domains.
86             More recently (since 2010) it has instituted an EPP system
87             which is sufficiently different from standard EPP that none of the
88             standard modules will work seamlessly with it.
89              
90             This module exists to provide a client interface to the Nominet EPP
91             servers. It is a subclass of L and aims to adhere
92             closely to that interface style so as to act as a drop-in replacement.
93              
94             =cut
95              
96       11     END {}
97              
98             # subs and methods
99              
100             =pod
101              
102             =head1 Constructor
103              
104             my $epp = Net::EPP::Registry::Nominet->new (
105             user => 'MYTAG',
106             pass => 'mypass'
107             ) or die ('Could not login to EPP server: ', $Net::EPP::Registry::Nominet::Message);
108              
109             The constructor for C has the same
110             general form as the one for L, but with the following
111             exceptions:
112              
113             =over
114              
115             =item * If C or C is set but C is not, C
116             defaults to 8700
117              
118             =item * C will be set to the appropriate endpoint. Specify C
119             with value 1 to connect to the OT&E endpoint, C with value 1 for
120             the testbed endpoint and none of these for the standard live endpoint.
121              
122             =item * C defaults to 5 (seconds).
123              
124             =item * C specifies the verbosity. 0 = almost silent, 1 = displays
125             warnings/errors, 2 = displays EPP frames in over-ridden methods. Default
126             is 0.
127              
128             =item * C changes the default number of years for
129             registrations and renewals from the system default of 2. This is only
130             used if no explicit number of years is given in each registration or
131             renewal command. It must be an integer between 1 and 10 inclusive (but
132             note that renewing for 10 years pre-expiry will always fail because
133             Nominet prohibits it).
134              
135             =item * C is a hashref of options to be passed directly
136             through as the third optional argument to L.
137              
138             =item * There is no facility for a config file but this may be added in
139             future versions.
140              
141             =item * There is no facility for supplying SSL client certificates
142             because there is no support for them in the Nominet EPP server.
143              
144             =back
145              
146             =cut
147              
148             sub new {
149 1     1 1 166 my ($class, %params) = @_;
150              
151             # Set the (deprecated) flag for XML responses. Should be the
152             # grandparent default anyway these days, but useful if someone tries
153             # to use with old version of Net::EPP.
154 1         4 $params{dom} = 1;
155              
156 1 50       5 if (defined $params{debug}) { $Debug = $params{debug}; }
  1         4  
157 1 50 33     9 if ($params{test} and $params{test} == 1) {
    50 33        
158             # Use test server
159 0 0 0     0 if ($params{testssl} and $params{testssl} == 1) {
160 0         0 $params{port} = 700;
161 0         0 $params{ssl} = 1;
162             } else {
163 0         0 $params{port} = 8700;
164 0         0 $params{ssl} = undef;
165             }
166 0         0 $params{host} = $Host{test};
167             } elsif ($params{ote} and $params{ote} == 1) {
168             # Use OT&E server
169 1 50 33     6 if ($params{testssl} and $params{testssl} == 1) {
170 0         0 $params{port} = 700;
171 0         0 $params{ssl} = 1;
172             } else {
173 1         3 $params{port} = 8700;
174 1         3 $params{ssl} = undef;
175             }
176 1         4 $params{host} = $Host{ote};
177             } else {
178             # Use live server
179 0         0 $params{port} = 700;
180 0         0 $params{ssl} = 1;
181 0         0 $params{host} = $Host{prod};
182             }
183 1 50       7 warn "Connecting to $params{host}:$params{port}\n" if $Debug;
184 1 50 50     8 $params{timeout} = (int($params{timeout} || 0) > 0 ? $params{timeout} : 5);
185 1 50       4 if ($params{ssl}) {
186 0 0       0 if ($params{verify}) {
187 0   0     0 $params{SSL_ca_file} ||= $params{ca_file};
188 0   0     0 $params{SSL_ca_path} ||= $params{ca_path};
189 0         0 $params{SSL_verify_mode} = 0x01;
190             } else {
191 0         0 $params{SSL_verify_mode} = 0x00;
192             }
193             }
194 1 0 33     4 if ($params{ssl} and $params{ciphers}) {
195 0         0 $params{SSL_cipher_list} = $params{ciphers};
196             }
197              
198 1         12 my $self = Net::EPP::Client->new(%params);
199 1 50       41 unless ($self->{timeout}) { $self->{timeout} = $params{timeout}; }
  1         3  
200 1 50       5 $self->{debug} = $Debug > 1 ? 1 : 0; # for parent
201              
202             # Set the default years.
203 1         3 $self->{def_years} = 2;
204 1 50       4 if (defined $params{def_years}) {
205 0         0 my $years = scalar $params{def_years};
206 0 0       0 if ($years =~ /^[0-9]+$/) {
207 0 0 0     0 if ($years > 0 and $years < 11) {
208 0         0 $self->{def_years} = $years;
209             } else {
210 0         0 carp "Supplied parameter def_years is not between 0 and 11";
211             }
212             } else {
213 0         0 carp "Supplied parameter def_years is not an integer";
214             }
215             }
216 1         3 $self->{authenticated} = 0;
217 1   50     7 $self->{reconnect} ||= 3; # Upwards compatibility
218              
219 1         2 bless($self, $class);
220              
221             # Connect to server
222 1 50       5 $self->_go_connect (%params) or return;
223              
224             # Login
225 0 0 0     0 unless (defined $params{login} and $params{login} == 0) {
226 0         0 $self->login ($params{user}, $params{pass}, $params{login_opt});
227             }
228              
229             # If there was an error in the constructor, there's no point
230             # continuing - return undef just like Net::EPP::Simple
231 0 0       0 return $Error ? undef : $self;
232             }
233              
234             sub _go_connect {
235 1     1   6 my ($self, %params) = @_;
236 1 50       4 if (scalar keys %params) {
237 1         9 $self->{connect_params} = \%params;
238             } else {
239 0         0 %params = %{$self->{connect_params}};
  0         0  
240             }
241              
242             # Connect to server
243 1         2 eval { $self->{greeting} = $self->connect (%params); };
  1         8  
244 1 50       38391 unless ($self->{greeting}) {
245 1         8 $self->{connected} = 0;
246 1         139 warn 'No greeting returned: cannot continue';
247 1 50       13 warn ($@) if $@;
248 1         27 return undef;
249             }
250 0         0 $self->{connected} = 1;
251             }
252              
253             =pod
254              
255             =head1 Login
256              
257             The client can perform a standalone EPP Login if required.
258              
259             $epp->login ($username, $password, $opt_ref)
260             or die ("Could not login: ", $epp->get_reason);
261              
262             The optional third argument, C<$opt_ref>, is a hash ref of login
263             options. Currently the only supported option is 'tag_list' which
264             should be set to a true value if the user needs to use the
265             L
266             method. Nominet operates a number of
267             L
268             so that the user needs to login again to perform different tasks. At present
269             this module only supports two sets: the standard tasks and the tag list.
270              
271             =cut
272              
273             sub login {
274 0     0 1 0 my ($self, $user, $pass, $options) = @_;
275              
276 0 0       0 if ($self->{authenticated}) {
277 0         0 $Error = 'Already logged in';
278 0         0 carp ($Error);
279 0         0 return;
280             }
281              
282 0 0       0 unless (defined $user) {
283 0         0 $Error = 'No username (tagname) supplied';
284 0         0 carp ($Error);
285 0         0 return;
286             }
287              
288 0 0       0 unless (defined $pass) {
289 0         0 $Error = 'No password supplied';
290 0         0 carp ($Error);
291 0         0 return;
292             }
293              
294 0 0       0 $self->_go_connect () unless $self->{connected};
295              
296             # Set login frame
297 0         0 my $login = Net::EPP::Frame::Command::Login->new;
298              
299 0         0 $login->clID->appendText($user);
300 0         0 $login->pw->appendText($pass);
301 0         0 $login->version->appendText($EPPVer);
302 0         0 $login->lang->appendText($EPPLang);
303              
304 0         0 my @ns = ();
305 0         0 my @svcs = ();
306 0         0 my $baseuri = 'http://www.nominet.org.uk/epp/xml';
307              
308 0 0       0 if ($options->{'tag_list'}) {
309 0         0 push @ns, 'nom-tag';
310             } else {
311 0         0 push @ns, qw/epp eppcom domain host contact secDNS/;
312 0         0 push @svcs, qw/domain-nom-ext-1.2 contact-nom-ext-1.0
313             std-notifications-1.2 std-warning-1.1 std-contact-id-1.0
314             std-release-1.0 std-handshake-1.0 nom-abuse-feed-1.0
315             std-fork-1.0 std-list-1.0 std-locks-1.0 std-unrenew-1.0/;
316             }
317             # Standard schemas and extensions
318 0         0 for my $ns (@ns) {
319 0         0 my $el = $login->createElement('objURI');
320 0         0 my $ver = $EPPVer;
321 0 0       0 $ver = 1.1 if $ns eq 'secDNS';
322 0         0 my $text = "urn:ietf:params:xml:ns:$ns-$ver";
323 0 0       0 $text = "$baseuri/$ns-$ver" if $ns =~ /-/;
324 0         0 $el->appendText($text);
325 0         0 $login->svcs->appendChild($el);
326             }
327             # Extensions go here
328 0 0       0 if (scalar @svcs) {
329 0         0 my $ext = $login->createElement('svcExtension');
330 0         0 for my $ns (@svcs) {
331 0         0 my $el = $login->createElement('extURI');
332 0         0 $el->appendText("$baseuri/$ns");
333 0         0 $ext->appendChild($el);
334             }
335 0         0 $login->svcs->appendChild($ext);
336             }
337              
338 0         0 my $response = $self->_send_frame ($login);
339              
340 0 0       0 if ($Code != 1000) {
341 0         0 $Error = "Error logging in (response code $Code)";
342 0         0 return undef;
343             }
344              
345 0         0 $self->{authenticated} = 1;
346 0         0 $self->{login_params} = [$user, $pass, $options];
347 0         0 return $self;
348             }
349              
350             sub logout {
351 1     1 0 78 my $self = shift;
352 1         12 my $res = $self->SUPER::logout (@_);
353 1 50       15038 $self->{authenticated} = 0 if $res;
354 1         191 return $res;
355             }
356              
357             =head1 Availability checks
358              
359             The availability checks work similarly to L except
360             that in list context they return an array with up to three elements.
361             The first element is the
362             availability indicator as before (0 if provisioned, 1 if available,
363             undef on error). The second element is the abuse counter which shows
364             how many more such checks you may run.
365             The third element gives the reason for the lack of availability, if any.
366              
367             These two extra fields are only relevant for check_domain and will always
368             be undef for the other check methods.
369              
370             # List context
371             my ($avail, $left, $reason) = $epp->check_domain ("foo.uk");
372             ($avail) = $epp->check_contact ("ABC123");
373             ($avail) = $epp->check_host ("ns0.foo.co.uk");
374              
375             # Scalar context
376             $avail = $epp->check_domain ("foo.uk");
377             $avail = $epp->check_contact ("ABC123");
378             $avail = $epp->check_host ("ns0.foo.co.uk");
379              
380             =cut
381              
382             sub _check {
383 0     0     my ($self, $type, $identifier) = @_;
384              
385             # If there's nothing to check, don't bother asking the server
386 0 0         unless (defined $identifier) {
387 0           $Error = "Missing identifier as argument";
388 0           carp $Error;
389 0           return undef;
390             }
391              
392 0           my $frame;
393 0           my @spec = $self->spec ($type);
394 0 0         my $key = $type eq 'contact' ? 'id' : 'name';
395 0 0 0       if ($type eq 'domain' or $type eq 'contact' or $type eq 'host') {
      0        
396 0           $frame = Net::EPP::Frame::Command::Check->new;
397 0           my $obj = $frame->addObject (@spec);
398 0           my $name = $frame->createElement ("$type:$key");
399 0           $name->appendText ($identifier);
400 0           $obj->appendChild ($name);
401 0           $frame->getCommandNode->appendChild ($obj);
402             } else {
403 0           $Error = "Unknown object type '$type'";
404 0 0         warn $Error if $Debug;
405 0           return undef;
406             }
407              
408 0 0         my $response = $self->_send_frame ($frame) or return undef;
409 0           my $avail = $response->getNode($spec[1], $key)->getAttribute('avail');
410 0 0         return $avail unless wantarray;
411              
412 0           my $extra = $response->getNode("$type-nom-ext:chkData");
413 0           my $count = undef;
414 0 0         $count = $extra->getAttribute('abuse-limit') if defined $extra;
415 0 0 0       warn "Remaining checks = $count\n" if ($Debug and defined $count);
416              
417 0           $extra = $response->getNode($spec[1], 'reason');
418 0           my $reason;
419 0 0         $reason = $extra->textContent if defined $extra;
420              
421 0           return ($avail, $count, $reason);
422             }
423              
424             =head1 Domain Renewal
425              
426             You can renew an existing domain with the renew() command.
427              
428             my $new_expiry = $epp->renew ({
429             name => $domstr,
430             cur_exp_date => $old_expiry,
431             period => $years
432             });
433              
434             On success, C<$new_expiry> contains the new expiry date in long form.
435             Otherwise returns undef.
436              
437             C<$domstr> is just the domain as a string, eg. "foo.co.uk".
438              
439             If you do not specify the old expiry date in your request, the system
440             will attempt to retrieve it from the registry first. It should be in the
441             form YYYY-MM-DD.
442              
443             C<$years> must be an integer between 1 and 10 inclusive and defaults to any
444             value specified in the constructor or 2 otherwise. 10 year renewals must
445             be post-expiry.
446              
447             =cut
448              
449             sub renew {
450 0     0 0   my ($self, $renew) = @_;
451 0 0         unless (defined $renew) {
452 0           carp "No argument provided";
453 0           return undef;
454             }
455 0 0 0       unless (ref $renew and ref $renew eq 'HASH') {
456 0           carp "Argument to renew is not a hash reference";
457 0           return undef;
458             }
459 0 0         unless ($renew->{name}) {
460 0           carp "Argument to renew has no 'name' field";
461 0           return undef;
462             }
463 0           my $domain = $renew->{name};
464 0           my $expiry = $renew->{cur_exp_date};
465 0           my $years = $renew->{period};
466 0           my @spec = $self->spec ('domain');
467 0           my $frame = Net::EPP::Frame::Command::Renew->new;
468 0           my $obj = $frame->addObject (@spec);
469 0           my $name = $frame->createElement ('domain:name');
470 0           $name->appendText ($domain);
471 0           $obj->appendChild ($name);
472              
473 0 0 0       unless (defined $expiry and $expiry =~ /^2\d\d\d-\d\d-\d\d$/) {
474 0 0 0       warn "Badly defined expiry (" . ($expiry || '') . ") - retrieving from registry" if $Debug;
475 0           my $dominfo = $self->domain_info ($domain);
476 0 0 0       unless ($dominfo->{exDate} and
477             $dominfo->{exDate} =~ /^2\d\d\d-\d\d-\d\d/) {
478 0           $Error = "Unable to get expiry date from registry for $domain";
479 0           warn $Error;
480 0           return undef;
481             }
482 0           $expiry = substr($dominfo->{exDate}, 0, 10);
483             }
484 0           $name = $frame->createElement ('domain:curExpDate');
485 0           $name->appendText ($expiry);
486 0           $obj->appendChild ($name);
487              
488 0   0       $years ||= $self->{def_years};
489 0           $name = $frame->createElement ('domain:period');
490 0           $name->appendText ($years);
491 0           $name->setAttribute ('unit', 'y');
492 0           $obj->appendChild ($name);
493              
494 0           $frame->getCommandNode->appendChild ($obj);
495              
496 0 0         if (my $response = $self->_send_frame ($frame)) {
497 0           my $date = $response->getNode ($spec[1], 'exDate')->firstChild->toString ();
498 0 0         warn "New expiry date = $date\n" if $Debug;
499 0           return $date;
500             }
501 0           return undef;
502             }
503              
504             =head1 Domain Unrenewal
505              
506             You can unrenew a list of recently renewed domains with the unrenew() command.
507              
508             my $new_expiry = $epp->unrenew ($domstr, $domstr2, ... )
509              
510             On success, C<$new_expiry> is a hashref with the domain names as keys and
511             the new expiry dates in long form as the values.
512             Otherwise returns an empty hashref or undef on complete failure.
513              
514             C<$domstr>, C<$domstr2> are just the domains as a string, eg. "foo.co.uk".
515              
516             =cut
517              
518             sub unrenew {
519 0     0 0   my ($self, @doms) = @_;
520              
521 0           my $type = 'u';
522 0           my @spec = $self->spec ($type);
523 0           my $frame = Net::EPP::Frame::Command::Update->new;
524              
525 0           my $elem = $frame->createElement ('u:unrenew');
526 0           $elem->setAttribute ("xmlns:$type", $spec[1]);
527              
528 0           for my $domain (@doms) {
529 0           my $name = $frame->createElement ('u:domainName');
530 0           $name->appendText ($domain);
531 0           $elem->appendChild ($name);
532             }
533 0           $frame->getCommandNode->appendChild ($elem);
534              
535 0 0         if (my $response = $self->_send_frame ($frame)) {
536            
537             # Results not necessarily returned by EPP in the same order.
538             # Construct a hash ref with domains as keys and expiry dates as
539             # values
540 0           my $dates = {};
541 0           for my $node ($response->getElementsByLocalName ('renData')) {
542 0           my $dom = $node->getChildrenByLocalName('name')->[0]->firstChild->toString;
543 0           my $exp = $node->getChildrenByLocalName('exDate')->[0]->firstChild->toString;
544 0           $dates->{$dom} = $exp;
545             }
546 0           return $dates;
547             }
548 0           return undef;
549             }
550              
551             =head1 Release domains
552              
553             To transfer a domain to another registrar, use the release_domain
554             method. Returns 1 on success (including success pending handshake), 0 on
555             failure
556              
557             my $res = $epp->release_domain ('foo.co.uk', 'OTHER_TAG');
558             if ($res) {
559             if ($epp->get_code == 1001) {
560             warn "Handshake pending\n";
561             }
562             } else {
563             warn "Could not release $dom: ", $epp->get_reason;
564             }
565              
566             =cut
567              
568             # This does not fit well with Standard EPP, so we need to create our own
569             # command frame from scratch
570             sub release_domain {
571 0     0 0   my ($self, $domain, $tag) = @_;
572 0           my $frame;
573 0           my $type = 'r';
574 0           my @spec = $self->spec ($type);
575 0           $frame = Net::EPP::Frame::Command::Update->new;
576              
577 0           my $elem = $frame->createElement ('r:release');
578 0           $elem->setAttribute ("xmlns:$type", $spec[1]);
579              
580 0           my $name = $frame->createElement ('r:domainName');
581 0           $name->appendText ($domain);
582 0           $elem->appendChild ($name);
583              
584 0           $name = $frame->createElement ('r:registrarTag');
585 0           $name->appendText ($tag);
586 0           $elem->appendChild ($name);
587 0           $frame->getCommandNode->appendChild ($elem);
588              
589 0           my $response = $self->_send_frame ($frame);
590 0 0 0       if ($Code > 999 and $Code < 1002) { return 1; }
  0            
591 0           return 0;
592             }
593              
594             =head1 Create objects
595              
596             Standard EPP allows the creation of domains, contacts and hosts
597             (nameservers). The same is true of Nominet's version, with several
598             differences.
599              
600             =head2 Register domains
601              
602             To register a domain, there must already be a registrant in the system.
603             You will need to create a hashref of the domain like this to perform the
604             registration.
605              
606              
607             my $domain = {
608             name => "foo.co.uk",
609             period => "5",
610             registrant => "ABC123",
611             nameservers => {
612             'nsname0' => "ns1.bar.co.uk",
613             'nsname1' => "ns2.bar.co.uk"
614             },
615             secDNS => [
616             {
617             keyTag => 123,
618             alg => 5,
619             digestType => 1,
620             digest => '8A9CEBB665B78E0142F1CEF47CC9F4205F600685'
621             }
622             ]
623             };
624             my ($res) = $epp->create_domain ($domain);
625             if ($res) {
626             print "Expiry date of new domain: $res->{expiry}\n";
627             } else {
628             warn "Domain not registered: ", $epp->get_reason, "\n";
629             }
630              
631             It returns undef on failure, 1 on success in scalar context and a
632             hashref on success in list context. Only the keys "expiry" and "regid"
633             in this hashref are populated so far.
634              
635             To register a new domain to a new registrant you can either create the
636             registrant first to get the ID or you can replace the 'registrant' value
637             in the C<$domain> with a hashref of the registrant and C will
638             create the registrant first as a handy shortcut.
639              
640             The alias C can be used in place of C.
641              
642             =cut
643              
644             sub register {
645 0     0 0   my $self = shift;
646 0           return $self->create_domain (@_);
647             }
648              
649             sub create_domain {
650 0     0 0   my ($self, $domain) = @_;
651              
652             # New contact? Register them first
653 0 0         if (ref $domain->{registrant}) {
654 0           my $contyes = $self->create_contact ($domain->{registrant});
655 0 0 0       if ($contyes and $contyes == 1) {
656 0           $domain->{registrant} = $domain->{registrant}->{id};
657             } else {
658 0           return undef;
659             }
660             }
661              
662 0           my $frame;
663 0           my @spec = $self->spec ('domain');
664 0           $frame = Net::EPP::Frame::Command::Create->new;
665 0           my $obj = $frame->addObject (@spec);
666 0           my $name = $frame->createElement ('domain:name');
667 0           $name->appendText ($domain->{name});
668 0           $obj->appendChild ($name);
669              
670             # Set the duration - integral years only
671 0           my $years = $domain->{period};
672 0   0       $years ||= $self->{def_years};
673 0           $name = $frame->createElement ('domain:period');
674 0           $name->appendText ($years);
675 0           $name->setAttribute ('unit', 'y');
676 0           $obj->appendChild ($name);
677              
678              
679             # Add in the nameservers, if any
680 0           my $ns = $domain->{nameservers};
681 0 0         if (scalar keys %$ns) {
682 0           my @hostspec = $self->spec ('host');
683 0           $name = $frame->createElement ('domain:ns');
684 0           $name->setNamespace ($hostspec[1], 'ns', 0);
685 0           for my $i (0..9) {
686 0 0         if ($ns->{"nsid$i"}) {
    0          
687             # Not used anymore. Logic kept in case Nominet reverse their
688             # decision
689 0           $self->_add_nsid ($name, $frame, $ns->{"nsid$i"});
690             } elsif ($ns->{"nsname$i"}) {
691 0           $self->_add_nsname ($name, $frame, $ns->{"nsname$i"});
692             }
693             }
694 0           $obj->appendChild ($name);
695             }
696              
697             # Set up the registrant
698 0           $name = $frame->createElement ('domain:registrant');
699 0           $name->appendText ($domain->{registrant});
700 0           $obj->appendChild ($name);
701              
702             # add auth
703             # Crazily, this element must be present to pass the XML checks, but
704             # after detecting its presence, Nominet subsequently ignores it.
705 0           $name = $frame->createElement ('domain:authInfo');
706 0           my $pw = $frame->createElement ('domain:pw');
707 0           $pw->appendText ('dummyvalue');
708 0           $name->appendChild ($pw);
709 0           $obj->appendChild ($name);
710              
711              
712             # DNSSEC
713 0           my $exttype = 'secDNS';
714 0 0         if ($domain->{$exttype}) {
715 0           my @spec = $self->spec ($exttype);
716 0           my $obj2 = $frame->addObject (@spec);
717 0           for my $dsrec (@{$domain->{$exttype}}) {
  0            
718 0           $self->_add_dsrec ($obj2, $frame, $dsrec);
719             }
720              
721 0           my $extension = $frame->command->new ('extension');
722 0           $extension->appendChild ($obj2);
723 0           $frame->command->insertAfter ($extension, $frame->getCommandNode);
724             }
725              
726             # Request complete, so send the frame
727 0           $frame->getCommandNode->appendChild ($obj);
728              
729 0           my $response = $self->_send_frame ($frame);
730 0 0         return undef unless $Code == 1000;
731 0           my $date = $response->getNode ($spec[1], 'exDate')->firstChild->toString ();
732 0 0         warn "expiry date = $date\n" if $Debug;
733              
734             # Perhaps this return should use wantarray instead?
735 0           return @{[{ expiry => $date, regid => $domain->{registrant} }]};
  0            
736             }
737              
738             =head2 Register accounts
739              
740             To register an account, you will need to create a hashref of the
741             account like this to perform the registration.
742              
743             my $registrant = {
744             'id' => "ABC123",
745             'name' => 'Example Company',
746             'trad-name' => 'Examples4u',
747             'type' => 'LTD',
748             'co-no' => '12345678',
749             'disclose' => {
750             'org' => 1,
751             'addr' => 0
752             },
753             'postalInfo' => { loc => {
754             'name' => 'Arnold N Other',
755             'org' => 'Example Company',
756             'addr' => {
757             'street' => ['555 Carlton Heights'],
758             'city' => 'Testington',
759             'sp' => 'Testshire',
760             'pc' => 'XL99 9XL',
761             'cc' => 'GB'
762             }
763             }},
764             'voice' => '+44.1234567890',
765             'email' => 'a.n.other@example.com'
766             };
767             my $res = $epp->create_contact ($registrant) or die $epp->get_reason;
768              
769             It returns undef on failure, 1 on success. The new id must be unique
770             (across the entire registry) otherwise the creation will fail. If no id
771             is specified a random one will be used instead and can subsequently be
772             extracted as C<$registrant-E{id}> in the calling code.
773              
774             =cut
775              
776             # Nominet now only has one contact per registrant, so this is
777             # effectively creating a new registrant.
778             sub create_contact {
779 0     0 0   my ($self, $contact) = @_;
780              
781             # Use random id if none supplied
782 0   0       $contact->{id} ||= $self->random_id;
783 0   0       $contact->{authInfo} ||= 12345;
784 0 0         unless (defined $contact->{fax}) { $contact->{fax} = ''; }
  0            
785 0 0 0       unless (defined $contact->{voice}) {
786 0           $Error = "Missing contact phone number";
787 0           return undef;
788             } elsif (not $self->valid_voice ($contact->{voice})) {
789             $Error = "Bad phone number $contact->{voice} should be +NNN.NNNNNNNNNN";
790             return undef;
791             }
792 0           my $frame = $self->_prepare_create_contact_frame($contact);
793              
794             # Extensions
795 0           my @spec = $self->spec ('contact-nom-ext');
796 0           my $obj = $frame->addObject (@spec);
797 0           for my $field (qw/ trad-name type co-no /) {
798 0 0         next unless ($contact->{$field});
799 0           my $name = $frame->createElement("contact-nom-ext:$field");
800 0           $name->appendText ($contact->{$field});
801 0           $obj->appendChild ($name);
802             }
803 0           my $extension = $frame->command->new ('extension');
804 0           $extension->appendChild ($obj);
805 0           $frame->command->insertAfter ($extension, $frame->getCommandNode);
806              
807 0 0         if (defined $contact->{disclose}) {
808 0           my $add = $frame->createElement ('contact:disclose');
809 0           $add->setAttribute('flag', '1');
810 0           for my $field (qw/org addr/) {
811 0 0         next unless $contact->{disclose}->{$field};
812 0           my $disc = $frame->createElement ("contact:$field");
813 0           $disc->setAttribute('type', 'loc');
814 0           $add->appendChild ($disc);
815             }
816 0 0         $frame->getNode('create')->getChildNodes->shift->appendChild ($add)
817             if $add->hasChildNodes;
818             }
819              
820 0           my $response = $self->_send_frame ($frame);
821 0 0         return $Code == 1000 ? 1 : undef;
822             }
823              
824             =head2 Register nameservers
825              
826             To register a nameserver:
827              
828             my $host = {
829             name => "ns1.foo.co.uk",
830             addrs => [
831             { ip => '10.2.2.1', version => 'v4' },
832             ],
833             };
834             my ($res) = $epp->create_host ($host);
835              
836             It returns undef on failure or 1 on success.
837              
838             =cut
839              
840             # Only need this to set $Code, which is rather annoying.
841             sub create_host {
842 0     0 0   my ($self, $host) = @_;
843 0           my $frame = $self->_prepare_create_host_frame($host);
844 0           return defined $self->_send_frame ($frame);
845             }
846              
847             sub _add_nsname {
848 0     0     my ($self, $name, $frame, $fqdn) = @_;
849 0           my $nsname = $frame->createElement ('domain:hostObj');
850 0           $nsname->appendText ($fqdn);
851 0           $name->appendChild ($nsname);
852 0           return;
853             }
854              
855             sub _add_nsaddr {
856 0     0     my ($self, $name, $frame, $addr) = @_;
857 0           my $nsaddr = $frame->createElement ('host:addr');
858 0           $nsaddr->setAttribute ('ip', $addr->{version});
859 0           $nsaddr->appendText ($addr->{ip});
860 0           $name->appendChild ($nsaddr);
861 0           return;
862             }
863              
864             sub _add_dsrec {
865 0     0     my ($self, $name, $frame, $dsrec) = @_;
866 0           my $ds = $frame->createElement ('secDNS:dsData');
867 0           for my $key (qw/ keyTag alg digestType digest /) {
868 0           my $field = $frame->createElement ("secDNS:$key");
869 0           $field->appendText ($dsrec->{$key});
870 0           $ds->appendChild ($field);
871             }
872 0           $name->appendChild ($ds);
873 0           return;
874             }
875              
876             =head1 Modify objects
877              
878             The domains, contacts and hosts once created can be modified using
879             these methods.
880              
881             =head2 Modify domains
882              
883             To modify a domain, you will need to create a hashref of the
884             changes like this:
885              
886             my $changes = {
887             'name' => 'foo.co.uk',
888             'add' => { ns => ['ns1.newhost.com', 'ns2.newhost.com'] },
889             'rem' => { ns => ['ns1.oldhost.net', 'ns2.oldhost.net'] },
890             'chg' => {},
891             'auto-bill' => 21,
892             'auto-period' => 5,
893             'next-bill' => '',
894             'notes' => ['A first note', 'The second note']
895             };
896             my $res = $epp->update_domain ($changes) or die $epp->get_reason;
897              
898             This example adds and removes nameservers using the C and C groups.
899             You cannot use C to change nameservers or extension fields. The C
900             entry is only used to move a domain between registrants with the same
901             name.
902              
903             The C and C groups are also used to add and remove DS records.
904             eg:
905              
906             my $changes = {
907             'name' => 'foo.co.uk',
908             'add' => {
909             secDNS => [{
910             keyTag => 25103,
911             alg => 5,
912             digestType => 1,
913             digest => '8A9CEBB665B78E0142F1CEF47CC9F4205F600685'
914             }]
915             },
916             'rem' => {}
917             };
918              
919             The extension fields can only be set outside of the add, rem and
920             chg fields. The supported extensions in this module are: C,
921             C, C, C, C and
922             C. All of these are scalars aside from C which is an array ref.
923              
924             C returns undef on failure, 1 on success.
925              
926             There is also a convenience method C which takes the
927             domain name as the first argument and the hashref of changes as the
928             second argument.
929              
930             =cut
931              
932             sub update_domain {
933 0     0 0   my ($self, $data) = @_;
934 0           return $self->modify_domain ($data->{name}, $data);
935             }
936              
937             sub modify_domain {
938 0     0 0   my ($self, $domain, $data) = @_;
939              
940             # Sort out the domain to be updated
941 0           my $frame;
942 0           my @spec = $self->spec ('domain');
943 0           $frame = Net::EPP::Frame::Command::Update->new;
944 0           my $obj = $frame->addObject (@spec);
945 0           my $name = $frame->createElement ('domain:name');
946 0           $name->appendText ($domain);
947 0           $obj->appendChild ($name);
948              
949             #Add nameservers as applicable
950 0           my @hostspec = $self->spec ('host');
951              
952 0           for my $action ('add', 'rem', 'chg') {
953 0 0         if ($data->{$action}) {
954 0           $name = $frame->createElement ("domain:$action");
955 0 0 0       if ($action ne 'chg' && $data->{$action}->{ns}) {
    0          
956 0           my $name2 = $frame->createElement ("domain:ns");
957 0           for my $ns (@{$data->{$action}->{ns}}) {
  0            
958 0           $self->_add_nsname ($name2, $frame, $ns);
959             }
960 0           $name->appendChild ($name2);
961             } elsif ($action eq 'chg') {
962 0 0         if ($data->{$action}->{registrant}) {
963 0           my $name2 = $frame->createElement ("domain:registrant");
964 0           $name2->appendText ($data->{$action}->{registrant});
965 0           $name->appendChild ($name2);
966             } else {
967 0           carp "'chg' is present but no 'registrant' field";
968             }
969             }
970 0           $obj->appendChild ($name);
971             }
972             }
973 0           $frame->getCommandNode->appendChild ($obj);
974              
975             # Extensions
976 0           @spec = $self->spec ('domain-nom-ext');
977 0           $obj = $frame->addObject (@spec);
978 0           for my $field (qw/ auto-bill auto-period
979             next-bill next-period renew-not-required reseller /) {
980 0 0         next unless ($data->{$field});
981 0           my $name = $frame->createElement("domain-nom-ext:$field");
982 0           $name->appendText ($data->{$field});
983 0           $obj->appendChild ($name);
984             }
985 0 0         if ($data->{notes}) {
986 0           for my $field (@{$data->{notes}}) {
  0            
987 0           my $name = $frame->createElement("domain-nom-ext:notes");
988 0           $name->appendText ($field);
989 0           $obj->appendChild ($name);
990             }
991             }
992             # DNSSEC
993             # Nominet does not support MaxSigLife which is the only possible use
994             # for 'chg', so do not cater for it here (yet).
995             #
996 0           my $exttype = 'secDNS';
997 0           @spec = $self->spec ($exttype);
998 0           my $obj2 = $frame->addObject (@spec);
999 0           for my $action ('rem', 'add') {
1000 0 0         if ($data->{$action}->{$exttype}) {
1001 0           $name = $frame->createElement ("$exttype:$action");
1002 0           for my $dsrec (@{$data->{$action}->{$exttype}}) {
  0            
1003 0           $self->_add_dsrec ($name, $frame, $dsrec);
1004             }
1005 0           $obj2->appendChild ($name);
1006             }
1007             }
1008              
1009 0           my $extension = $frame->command->new ('extension');
1010 0           $extension->appendChild ($obj);
1011 0           $extension->appendChild ($obj2);
1012 0           $frame->command->insertAfter ($extension, $frame->getCommandNode);
1013              
1014 0           my $response = $self->_send_frame ($frame);
1015 0 0         return $Code == 1000 ? 1 : undef;
1016             }
1017              
1018              
1019             =head2 Modify contacts
1020              
1021             To modify a contact, which includes aspects of the registrant such as
1022             the disclose flags etc., you will again need to create a hashref of the
1023             changes like this:
1024              
1025             my $changes = {
1026             'id' => 'ABC123',
1027             'type' => 'FCORP',
1028             'trad-name' => 'American Industries',
1029             'co-no' => '99998888',
1030             'postalInfo' => {
1031             'loc' => {
1032             'name' => 'James Johnston',
1033             'addr' => {
1034             'street' => ['7500 Test Plaza', 'Testingburg'],
1035             'city' => 'Testsville',
1036             'sp' => 'Testifornia',
1037             'pc' => '99999',
1038             'cc' => 'US',
1039             }
1040             }
1041             },
1042             'voice' => '+1.77777776666',
1043             'email' => 'jj@example.com',
1044             'disclose' => {
1045             'addr' => 1
1046             }
1047             };
1048             my $res = $epp->update_contact ($changes) or die $epp->get_reason;
1049              
1050             Note that this differs from the syntax of L where that
1051             takes the stock C, C and C elements.
1052              
1053             It returns undef on failure, 1 on success.
1054              
1055             There is also a convenience method C which takes the
1056             contact id as the first argument and the hashref of changes as the
1057             second argument.
1058              
1059             Note that due to an undocumented restriction in Nominet's EPP servers
1060             it is not possible to modify the disclose flags for both addr and org
1061             to different values in one request.
1062              
1063             If the hashref contains the key C like so:
1064              
1065             my $changes = { id => 'ABC123', 'new-id' => 'XYZ789' };
1066              
1067             then the ID of the contact will be changed to the new ID (which must
1068             be unique in the entire registry). In this case any other fields in the
1069             hashref will be ignored.
1070              
1071             =cut
1072              
1073             sub update_contact {
1074 0     0 0   my ($self, $data) = @_;
1075 0           return $self->modify_contact ($data->{id}, $data);
1076             }
1077              
1078             sub modify_contact {
1079 0     0 0   my ($self, $cont, $data) = @_;
1080              
1081             # If given a 'new-id', update that and nothing else
1082             return $self->_modify_contact_id ($cont, $data->{'new-id'})
1083 0 0         if exists $data->{'new-id'};
1084              
1085             # Sort out the contact to be updated
1086 0           my $frame;
1087 0           my @spec = $self->spec ('contact');
1088 0           $frame = Net::EPP::Frame::Command::Update->new;
1089 0           my $obj = $frame->addObject (@spec);
1090 0           my $name = $frame->createElement ('contact:id');
1091 0           $name->appendText ($cont);
1092 0           $obj->appendChild ($name);
1093 0           my $chg = $frame->createElement ('contact:chg');
1094              
1095             # Ideally we should be able to do this:
1096             # $data->{id} ||= $cont;
1097             # my $frame = $self->_generate_update_contact_frame($data);
1098             # but it won't work because of present, but empty, add/rem/chg
1099             # elements. Equally we cannot do this:
1100             # my $frame = Net::EPP::Frame::Command::Update::Contact->new;
1101             # $frame->setContact ( $cont );
1102             # so instead it needs this extra chunk of code which follows:
1103              
1104             # Set contact details
1105 0 0         if (defined $data->{postalInfo}) {
1106             #Update name and addr
1107 0           for my $intloc ('int', 'loc') {
1108 0 0         next unless $data->{postalInfo}->{$intloc};
1109 0           my $elem = $frame->createElement ("contact:postalInfo");
1110 0           $elem->setAttribute('type', $intloc);
1111             # Name change?
1112 0           my $thisone = $data->{postalInfo}->{$intloc};
1113 0 0         if ($thisone->{name}) {
1114 0           my $newname = $frame->createElement ('contact:name');
1115 0           $newname->appendText ($thisone->{name});
1116 0           $elem->appendChild ($newname);
1117             }
1118 0 0         if ($thisone->{addr}) {
1119 0           my $addr = $frame->createElement ('contact:addr');
1120 0           for my $addrbitkey (qw/street city sp pc cc/) {
1121 0 0         next unless defined $thisone->{addr}->{$addrbitkey};
1122 0           my $addrbit = $thisone->{addr}->{$addrbitkey};
1123 0 0         if (ref($addrbit) eq 'ARRAY') {
1124             # Only for street
1125 0           for my $street (@$addrbit) {
1126 0           my $stbit = $frame->createElement ("contact:$addrbitkey");
1127 0           $stbit->appendText ($street);
1128 0           $addr->appendChild ($stbit);
1129             }
1130             } else {
1131 0           my $field = $frame->createElement ("contact:$addrbitkey");
1132 0           $field->appendText ($addrbit);
1133 0           $addr->appendChild ($field);
1134             }
1135             }
1136 0           $elem->appendChild($addr);
1137             }
1138 0           $chg->appendChild ($elem);
1139             }
1140             }
1141 0 0 0       if (defined $data->{voice} and not $self->valid_voice ($data->{voice})) {
1142 0           $Error = "Bad phone number $data->{voice} should be +NNN.NNNNNNNNNN";
1143 0           return undef;
1144             }
1145 0           for my $field ('voice', 'email') {
1146 0 0         next unless defined $data->{$field};
1147 0           my $elem = $frame->createElement ("contact:$field");
1148 0           $elem->appendText ($data->{$field});
1149 0           $chg->appendChild ($elem);
1150             }
1151 0 0         if (defined $data->{disclose}) {
1152             # Return an error if there's a mix of flags
1153 0           my @flags = values (%{$data->{disclose}});
  0            
1154 0 0 0       if ($#flags > 0 && $flags[0] != $flags[1]) {
1155 0           $Error = "Nominet prohibits adding and removing disclosures " .
1156             "in one action";
1157 0           return;
1158             }
1159             # This doesn't need to be so complicated but it's staying this
1160             # way in case Nominet decide to allow a mix of actions in the
1161             # future.
1162 0           my $add = $frame->createElement ('contact:disclose');
1163 0           $add->setAttribute('flag', '1');
1164 0           my $del = $frame->createElement ('contact:disclose');
1165 0           $del->setAttribute('flag', '0');
1166 0           for my $field (qw/org addr/) {
1167 0 0         next unless defined $data->{disclose}->{$field};
1168 0           my $disc = $frame->createElement ("contact:$field");
1169 0           $disc->setAttribute('type', 'loc');
1170 0 0         ($data->{disclose}->{$field} ? $add : $del)->appendChild ($disc);
1171             }
1172 0           for my $child ($add, $del) {
1173 0 0         $chg->appendChild ($child) if $child->hasChildNodes;
1174             }
1175             }
1176 0 0         if ($chg->hasChildNodes) { $obj->appendChild($chg); }
  0            
1177              
1178             # Extensions
1179 0           @spec = $self->spec ('contact-nom-ext');
1180 0           $obj = $frame->addObject (@spec);
1181 0           for my $field (qw/ trad-name type co-no /) {
1182 0 0         next unless ($data->{$field});
1183 0           my $name = $frame->createElement("contact-nom-ext:$field");
1184 0           $name->appendText ($data->{$field});
1185 0           $obj->appendChild ($name);
1186             }
1187 0           my $extension = $frame->command->new ('extension');
1188 0           $extension->appendChild ($obj);
1189 0           $frame->command->insertAfter ($extension, $frame->getCommandNode);
1190              
1191 0           my $response = $self->_send_frame($frame);
1192 0 0         return $Code == 1000 ? 1 : undef;
1193             }
1194              
1195             sub _modify_contact_id {
1196 0     0     my ($self, $old_id, $new_id) = @_;
1197              
1198 0           my @spec = $self->spec ('contact-id');
1199 0           my $frame = Net::EPP::Frame::Command::Update->new;
1200 0           my $obj = $frame->addObject (@spec);
1201 0           my $id = $frame->createElement ('contact-id:id');
1202 0           $id->appendText ($old_id);
1203 0           $obj->appendChild ($id);
1204 0           my $chg = $frame->createElement ('contact-id:chg');
1205 0           $id = $frame->createElement ('contact-id:id');
1206 0           $id->appendText ($new_id);
1207 0           $chg->appendChild ($id);
1208 0           $obj->appendChild ($chg);
1209              
1210 0           $frame->getCommandNode->appendChild ($obj);
1211 0           my $response = $self->_send_frame ($frame);
1212 0 0         return $Code == 1000 ? 1 : undef;
1213             }
1214              
1215             =head2 Modify nameservers
1216              
1217             To modify a nameserver, you will need to create a hashref of the
1218             changes like this:
1219              
1220             my $changes = {
1221             name => 'ns1.foo.co.uk',
1222             add => { 'addr' => [ { ip => '192.168.0.51', version => 'v4' } ] },
1223             rem => { 'addr' => [ { ip => '192.168.0.50', version => 'v4' } ] },
1224             };
1225             my $res = $epp->update_host ($changes) or die $epp->get_reason;
1226              
1227             This operation can only be used to add and remove ip addresses. The C
1228             element is not permitted to change addresses, so it is likely that only
1229             the C and C elements will ever be needed.
1230              
1231             It returns undef on failure, 1 on success.
1232              
1233             There is also a convenience method C which takes the
1234             host name as the first argument and the hashref of changes as the
1235             second argument.
1236              
1237             =cut
1238              
1239             sub update_host {
1240 0     0 0   my ($self, $data) = @_;
1241 0           return $self->modify_host ($self, $data->{name}, $data);
1242             }
1243              
1244             sub modify_host {
1245 0     0 0   my ($self, $host, $data) = @_;
1246              
1247             # Sort out the domain to be updated
1248 0           my $frame;
1249 0           my @spec = $self->spec ('host');
1250 0           $frame = Net::EPP::Frame::Command::Update->new;
1251 0           my $obj = $frame->addObject (@spec);
1252 0           my $name = $frame->createElement ('host:name');
1253 0           $name->appendText ($host);
1254 0           $obj->appendChild ($name);
1255              
1256 0           for my $action ('add', 'rem', 'chg') {
1257 0 0         if ($data->{$action}) {
1258 0           $name = $frame->createElement ("host:$action");
1259 0 0         if ($data->{$action}->{addr}) {
1260             #my $name2 = $frame->createElement ("host:addr");
1261 0           for my $addr (@{$data->{$action}->{addr}}) {
  0            
1262 0           $self->_add_nsaddr ($name, $frame, $addr);
1263             }
1264             #$name->appendChild ($name2);
1265             }
1266 0           $obj->appendChild ($name);
1267             }
1268             }
1269              
1270 0           $frame->getCommandNode->appendChild ($obj);
1271 0           my $response = $self->_send_frame ($frame);
1272 0 0         return $Code == 1000 ? 1 : undef;
1273             }
1274              
1275             =head1 Fork contact
1276              
1277             my $res = $epp->fork ($old_id, $new_id, @domains);
1278              
1279             Splitting out some domains on a contact to a copy of that contact can be
1280             achieved using C. The first optional argument is the existing
1281             contact ID. If this is undef then the existing contact will be that on
1282             the listed domains.
1283              
1284             The second optional argument is the ID of the new contact to create. If
1285             this is undef then a random ID will be assigned by Nominet.
1286              
1287             The third and subsequent arguments are the domain names to be moved from the
1288             existing contact to the new.
1289              
1290             Returns the new contact ID on success, undef otherwise.
1291              
1292             =cut
1293              
1294             sub fork {
1295 0     0 0   my ($self, $old_id, $new_id, @doms) = @_;
1296              
1297 0           my $type = 'f';
1298 0           my @spec = $self->spec ($type);
1299 0           my $frame = Net::EPP::Frame::Command::Update->new;
1300              
1301 0           my $obj = $frame->createElement ('f:fork');
1302 0           $obj->setAttribute ("xmlns:$type", $spec[1]);
1303              
1304 0 0         if (defined $old_id) {
1305 0           my $id = $frame->createElement ('f:contactId');
1306 0           $id->appendText ($old_id);
1307 0           $obj->appendChild ($id);
1308             }
1309 0 0         if (defined $new_id) {
1310 0           my $id = $frame->createElement ('f:newContactId');
1311 0           $id->appendText ($new_id);
1312 0           $obj->appendChild ($id);
1313             }
1314 0           for my $dom (@doms) {
1315 0           my $elem = $frame->createElement ('f:domainName');
1316 0           $elem->appendText ($dom);
1317 0           $obj->appendChild ($elem);
1318             }
1319              
1320 0           $frame->getCommandNode->appendChild ($obj);
1321 0           my $response = $self->_send_frame ($frame);
1322 0 0         return undef unless $Code == 1000;
1323 0           my $id = $response->getNode ('contact:id')->firstChild->toString ();
1324 0 0         warn "Forked contact ID is $id\n" if $Debug;
1325 0           return $id;
1326             }
1327              
1328             =head1 Querying objects
1329              
1330             The interface for querying domains, contacts and hosts is the same as
1331             for L with the addendum that authinfo is not used at
1332             Nominet so can be ignored. The interface is simply:
1333              
1334             my $domhash = $epp->domain_info($domainname);
1335             my $fulldomhash = $epp->domain_info($domainname, undef, $follow);
1336             my $conthash = $epp->contact_info ($contid);
1337             my $hosthash = $epp->host_info ($hostname);
1338              
1339             =cut
1340              
1341             sub _info {
1342 0     0     my ($self, $type, $identifier) = @_;
1343 0           my $frame;
1344 0 0         warn "In _info, type = $type\n" if $Debug;
1345 0 0         if ($type eq 'domain') {
    0          
    0          
1346 0           my @spec = $self->spec ('domain');
1347 0           $frame = Net::EPP::Frame::Command::Info->new;
1348             # The stock frame adds an incorrect domain element - need it
1349             # removed or overwritten first
1350 0           my $obj = $frame->addObject (@spec);
1351 0           my $name = $frame->createElement ('domain:name');
1352 0           $name->appendText ($identifier);
1353 0           $obj->appendChild ($name);
1354 0           $frame->getCommandNode->appendChild ($obj);
1355             } elsif ($type eq 'contact') {
1356 0           my @spec = $self->spec ($type);
1357 0           $frame = Net::EPP::Frame::Command::Info->new;
1358 0           my $obj = $frame->addObject (@spec);
1359 0           my $name = $frame->createElement ('contact:id');
1360 0           $identifier =~ s/-UK$//;
1361 0           $name->appendText ($identifier);
1362 0           $obj->appendChild ($name);
1363 0           $frame->getCommandNode->appendChild ($obj);
1364             } elsif ($type eq 'host') {
1365 0           $frame = Net::EPP::Frame::Command::Info::Host->new;
1366 0           $frame->setHost($identifier);
1367             } else {
1368 0           $Code = 0;
1369 0           $Error = "Unknown object type '$type'";
1370 0           return undef;
1371             }
1372              
1373 0 0         my $response = $self->_send_frame ($frame) or return undef;
1374 0           my $infData = $response->getNode(($self->spec($type))[1], 'infData');
1375              
1376 0 0         if ($type eq 'domain') {
    0          
    0          
1377 0           my $extra = $response->getNode('domain-nom-ext:infData');
1378 0           my $secdns = $response->getNode('secDNS:infData');
1379 0           return $self->_domain_infData_to_hash($infData, $extra, $secdns);
1380             } elsif ($type eq 'contact') {
1381             # Grab disclose infdata before Net::EPP::Simple deletes it
1382 0           my $disclose = $self->_disclose_infData_to_hash ($infData);
1383 0           $self->_clean_addr($infData);
1384 0           my $this = $self->_contact_infData_to_hash($infData);
1385             # Add in the Nominet extras (reg, rather than contact)
1386 0           my $extra = $response->getNode('contact-nom-ext:infData');
1387 0           return $self->_merge_contact_infData ($this, $extra, $disclose);
1388             } elsif ($type eq 'host') {
1389 0           return $self->_host_infData_to_hash($infData);
1390             }
1391             }
1392              
1393             sub _domain_infData_to_hash {
1394 0     0     my ($self, $infData, $extra, $secdns) = @_;
1395              
1396 0           my $hash = $self->_node_to_hash ($infData, ['registrant',
1397             'clID', 'crID', 'crDate', 'exDate', 'name', 'roid']);
1398              
1399 0           my $extrahash = $self->_node_to_hash ($extra, [
1400             'auto-bill', 'next-bill', 'auto-period',
1401             'next-period', 'reg-status', 'renew-not-required', 'notes', 'reseller']);
1402              
1403 0           for (keys %$extrahash) {
1404 0           $hash->{$_} = $extrahash->{$_};
1405             }
1406              
1407 0 0         if ($secdns) {
1408 0           my $dsObjs = $secdns->nonBlankChildNodes;
1409 0           while (my $dsObj = $dsObjs->shift) {
1410 0           push @{$hash->{secDNS}}, $self->_node_to_hash ($dsObj);
  0            
1411             }
1412             }
1413              
1414 0           my $hostObjs = $infData->getElementsByLocalName('hostObj');
1415 0           while (my $hostObj = $hostObjs->shift) {
1416 0           push(@{$hash->{ns}}, $hostObj->textContent);
  0            
1417             }
1418              
1419 0           return $hash;
1420             }
1421              
1422             sub _disclose_infData_to_hash {
1423 0     0     my ($self, $infData) = @_;
1424 0           my $disc = $infData->getElementsByLocalName('disclose')->shift;
1425 0 0         return unless $disc;
1426 0           my $flag = $disc->getAttribute('flag');
1427 0           my $hash;
1428 0           for my $child ($disc->getChildrenByTagName('*')) {
1429 0           $hash->{$child->localname} = $flag;
1430             }
1431 0           return $hash;
1432             }
1433              
1434             sub _tag_infData_to_hash {
1435 0     0     my ($self, $infData) = @_;
1436 0           return $self->_node_to_hash ($infData, ['registrar-tag',
1437             'name', 'handshake', 'trad-name']);
1438             }
1439              
1440             sub _clean_addr {
1441 0     0     my ($self, $infData) = @_;
1442             # Remove the whitespace text nodes from the addresses as
1443             # Net::EPP::Simple does not handle them nicely
1444 0           for my $addr ($infData->getElementsByTagName('contact:addr')) {
1445 0           for my $child ($addr->childNodes) {
1446 0 0         $addr->removeChild ($child)
1447             unless $child->nodeType == XML::LibXML::XML_ELEMENT_NODE;
1448             }
1449             }
1450             }
1451              
1452             sub _merge_contact_infData {
1453 0     0     my ($self, $old, $extra, $disclose) = @_;
1454              
1455 0           my $extrahash = $self->_node_to_hash ($extra, ['type',
1456             'co-no', 'trad-name']);
1457              
1458 0           for (keys %$extrahash) {
1459 0           $old->{$_} = $extrahash->{$_};
1460             }
1461 0           $old->{disclose} = $disclose;
1462 0           return $old;
1463              
1464             }
1465              
1466             sub _node_to_hash {
1467 0     0     my ($self, $node, $namelist) = @_;
1468 0           my $hash = {};
1469 0           foreach my $child ($node->childNodes) {
1470 0 0         next if $child->nodeType != 1;
1471 0           my $tag = $child->localname;
1472 0           my $value = $child->textContent;
1473 0 0         if ($hash->{$tag}) {
1474 0           $hash->{$tag} .= "\n$value";
1475             } else {
1476 0           $hash->{$tag} = $value;
1477             }
1478             }
1479             # Not very efficient for a deep copy, but it works.
1480 0 0         if ($namelist) {
1481 0           my $temp = {};
1482 0           for my $key (@$namelist) {
1483 0   0       $temp->{$key} = $hash->{$key} || '';
1484             }
1485 0           $hash = $temp;
1486             }
1487 0           return $hash;
1488             }
1489              
1490             =head1 List Domains
1491              
1492             Nominet allows listing domains either by registration date (ie. creation
1493             date) or expiry date. The date must be a month in the form YYYY-MM. eg.
1494              
1495             my $domlist = $epp->list_domains ('2019-01', 'expiry');
1496              
1497             will list all the domains expiring in January 2019 as an arrayref. It
1498             will return an empty array ref if there are no matches and undef on
1499             error. The second argument can only be 'expiry' or 'month' (for creation
1500             date). If it is not supplied, the default is 'expiry'.
1501              
1502             =cut
1503              
1504             sub list_domains {
1505 0     0 0   my $self = shift;
1506 0           my $range = shift;
1507 0   0       my $datetype = shift || 'expiry';
1508 0           my $type = 'l';
1509 0           my @spec = $self->spec ($type);
1510 0           my $frame = Net::EPP::Frame::Command::Info->new;
1511 0           my $name = $frame->createElement ('l:list');
1512 0           $name->setAttribute ("xmlns:$type", $spec[1]);
1513 0           my $child = $frame->createElement ("l:$datetype");
1514 0           $child->appendText ($range);
1515 0           $name->appendChild ($child);
1516 0           $frame->getCommandNode->appendChild ($name);
1517              
1518 0 0         my $response = $self->_send_frame($frame) or return undef;
1519 0 0         if ($Code != 1000) { return undef; }
  0            
1520              
1521 0           my $infData = $response->getNode(($self->spec($type))[1], 'listData');
1522 0           my $domlist = [];
1523 0           for my $node ($infData->childNodes) {
1524 0           my $txt = $node->textContent;
1525 0 0         push @$domlist, $txt if $txt =~ /\./;
1526             }
1527              
1528 0           return $domlist;
1529             }
1530              
1531             =head2 List Tags
1532              
1533             When transferring domains it may be useful to have a list of possible
1534             tag names. This method returns the full list of tags as an array ref.
1535             Each entry in the arrayref is itself a hashref with these keys:
1536              
1537             =over
1538              
1539             =item C is the tag name to use in release actions, etc.
1540              
1541             =item C is the name of the registrar for display purposes
1542              
1543             =item C is the trading name of the registrar (may be empty
1544             string)
1545              
1546             =item C is "Y" if they require handshakes on transfer
1547             or "N" otherwise
1548              
1549             =back
1550              
1551             my $taglist = $epp->list_tags;
1552              
1553             It accepts no arguments and returns undef on error.
1554              
1555             Note that you must have passed the C option to L
1556             in order to use this method.
1557              
1558             =cut
1559              
1560             sub list_tags {
1561 0     0 0   my $self = shift;
1562 0           my $type = 'tag';
1563 0           my @spec = $self->spec ($type);
1564 0           my $frame = Net::EPP::Frame::Command::Info->new;
1565 0           my $name = $frame->createElement ('tag:list');
1566 0           $name->setAttribute ("xmlns:$type", $spec[1]);
1567 0           $frame->getCommandNode->appendChild ($name);
1568              
1569 0 0         my $response = $self->_send_frame($frame) or return undef;
1570 0 0         if ($Code != 1000) { return undef; }
  0            
1571              
1572 0           my $infData = $response->getNode($spec[1], 'listData');
1573 0           my $taglist = [];
1574 0           for my $node ($infData->childNodes) {
1575 0 0         next unless $node->nodeType == XML::LibXML::XML_ELEMENT_NODE;
1576 0           push @$taglist, $self->_tag_infData_to_hash ($node);
1577             }
1578 0           return $taglist;
1579             }
1580              
1581             =head1 Hello
1582              
1583             EPP allows the use of a "hello" operation which effectively tests that
1584             the connection to the EPP server is still active and also serves to
1585             reset any inactivity timeout which the server might apply. Nominet's
1586             documentation seems to indicate a 60 minute timeout (as at August 2013).
1587              
1588             my $res = $epp->hello ();
1589            
1590             The hello method takes no arguments. It returns 1 on success, undef
1591             otherwise.
1592              
1593             This performs much the same function as the ping method of
1594             L (which could be used instead) but provides more
1595             extensive error handling.
1596              
1597             =cut
1598              
1599             sub hello {
1600 0     0 0   my $self = shift;
1601 0 0         unless ($self->{connected}) {
1602 0 0         warn "Hello attempt while disconnected\n" if $Debug;
1603 0           return undef;
1604             }
1605 0           my $frame = Net::EPP::Frame::Hello->new;
1606              
1607 0 0         warn "Sending XML = \n" . $frame . "\n" if $Debug > 1;
1608 0           my $greeting = $self->request($frame);
1609 0 0 0       warn "Response XML = \n" . $greeting->toString() . "\n"
1610             if ($Debug > 1 && defined $greeting);
1611              
1612 0 0         unless ($greeting) {
1613 0           $Error = sprintf("Server returned a %d code", $Code);
1614 0           return undef;
1615             }
1616             # greeting returned. Interested in details?
1617 0           return 1;
1618             }
1619              
1620             =head1 Utility methods
1621              
1622             The following utility methods are used internally but are described
1623             here in case they are useful for other purposes.
1624              
1625             =head2 spec
1626              
1627             This utility method takes a 'type' argument and returns a three-valued
1628             array of type, XMLNS and XSI for use with various frame and XML
1629             routines. It is not expected to be called independently by the user but
1630             is here if you need it.
1631              
1632             Type can currently be one of: domain, contact, contact-ext, contact-id
1633             host, l (for list), u (for unrenew), r (for release), f (for fork)
1634              
1635             my @spec = $epp->spec ('domain');
1636              
1637             =cut
1638              
1639             sub spec {
1640 0     0 1   my ($self, $type) = @_;
1641              
1642 0 0         return '' unless $type;
1643              
1644 0 0         if ($type eq 'domain') {
1645 0           return ($type,
1646             "urn:ietf:params:xml:ns:domain-$EPPVer",
1647             "urn:ietf:params:xml:ns:domain-$EPPVer domain-$EPPVer.xsd");
1648             }
1649 0 0 0       if ($type eq 'domain-ext' or $type eq 'domain-nom-ext') {
1650 0           return ($type,
1651             'http://www.nominet.org.uk/epp/xml/domain-nom-ext-1.2',
1652             'http://www.nominet.org.uk/epp/xml/domain-nom-ext-1.2 domain-nom-ext-1.2.xsd');
1653             }
1654 0 0         if ($type eq 'secDNS') {
1655 0           my $ver = 1.1;
1656 0           return ($type,
1657             "urn:ietf:params:xml:ns:secDNS-$ver",
1658             "urn:ietf:params:xml:ns:secDNS-$ver secDNS-$ver.xsd");
1659             }
1660 0 0         if ($type eq 'contact') {
1661 0           return ($type,
1662             "urn:ietf:params:xml:ns:contact-$EPPVer",
1663             "urn:ietf:params:xml:ns:contact-$EPPVer contact-$EPPVer.xsd");
1664             }
1665 0 0 0       if ($type eq 'contact-ext' or $type eq 'contact-nom-ext') {
1666 0           return ($type,
1667             'http://www.nominet.org.uk/epp/xml/contact-nom-ext-1.0',
1668             'http://www.nominet.org.uk/epp/xml/contact-nom-ext-1.0 contact-nom-ext-1.0.xsd');
1669             }
1670 0 0 0       if ($type eq 'contact-ext' or $type eq 'contact-id') {
1671 0           return ($type,
1672             'http://www.nominet.org.uk/epp/xml/std-contact-id-1.0',
1673             'http://www.nominet.org.uk/epp/xml/std-contact-id-1.0 std-contact-id-1.0.xsd');
1674             }
1675 0 0         if ($type eq 'host') {
1676 0           return ($type,
1677             "urn:ietf:params:xml:ns:host-$EPPVer",
1678             "urn:ietf:params:xml:ns:host-$EPPVer host-$EPPVer.xsd");
1679             }
1680 0 0         if ($type eq 'l') {
1681 0           return ($type,
1682             "http://www.nominet.org.uk/epp/xml/std-list-1.0",
1683             "http://www.nominet.org.uk/epp/xml/std-list-1.0 std-list-1.0.xsd");
1684             }
1685 0 0         if ($type eq 'u') {
1686 0           return ($type,
1687             "http://www.nominet.org.uk/epp/xml/std-unrenew-1.0",
1688             "http://www.nominet.org.uk/epp/xml/std-unrenew-1.0 std-unrenew-1.0.xsd");
1689             }
1690 0 0         if ($type eq 'r') {
1691 0           return ($type,
1692             "http://www.nominet.org.uk/epp/xml/std-release-1.0",
1693             "http://www.nominet.org.uk/epp/xml/std-release-1.0 std-release-1.0.xsd");
1694             }
1695 0 0         if ($type eq 'f') {
1696 0           return ($type,
1697             "http://www.nominet.org.uk/epp/xml/std-fork-1.0",
1698             "http://www.nominet.org.uk/epp/xml/std-fork-1.0 std-fork-1.0.xsd");
1699             }
1700 0 0         if ($type eq 'tag') {
1701 0           return ($type,
1702             "http://www.nominet.org.uk/epp/xml/nom-tag-$EPPVer",
1703             "http://www.nominet.org.uk/epp/xml/nom-tag-$EPPVer nom-tag-$EPPVer.xsd");
1704             }
1705             }
1706              
1707             =head2 valid_voice
1708              
1709             The valid_voice method takes one argument which is a
1710             string representing a telephone number and returns 1 if it is a valid
1711             string for the "voice" field of a contact or undef otherwise.
1712              
1713             unless ($epp->valid_voice ($phone)) {
1714             die "The phone number $phone is not in a valid format.";
1715             }
1716              
1717             =cut
1718              
1719             sub valid_voice {
1720 0     0 1   my $self = shift;
1721 0 0         my $phone = shift or return undef;
1722 0 0         if ($phone !~ /^\+\d{1,3}\.[0-9x]+$/) {
1723 0           $Error = "Bad phone number $phone should be +NNN.NNNNNNNNNN";
1724 0           return undef;
1725             }
1726 0           return 1;
1727             }
1728              
1729             =head2 random_id
1730              
1731             The random_id method takes an integer as its optional argument and
1732             returns a random string suitable for use as an ID. When creating a new
1733             contact an ID must be supplied and it must not be globally unique within
1734             the registry (not just within the TAG). This method is used to generate
1735             one of 26339361174458854765907679379456 possible 16-character IDs,
1736             rendering clashes less likely that winning the Lottery two weeks
1737             running (ie. good enough FAPP).
1738              
1739             my $almost_unique_id = $epp->random_id (16);
1740              
1741             The length defaults to 16 if not supplied. RFC 5730 specifies that this
1742             is the maximum length for a contact ID.
1743              
1744             =cut
1745              
1746             sub random_id {
1747             # Produce a random 16-character string suitable for use as an object
1748             # ID string if none provided.
1749             # RFC 5730 says 16 chars max for contact ID
1750 0     0 1   my ($self, $len) = @_;
1751 0   0       $len ||= 16;
1752 0           my $randstr = '';
1753 0           while (length ($randstr) < $len) {
1754 0           my $num = int(rand(94)) + 33;
1755 0 0 0       next if ($num == 38 or $num == 60); # XML chars - could escape, but no need
1756 0           $randstr .= chr($num);
1757             }
1758 0           return $randstr;
1759             }
1760              
1761             =head1 Accessors
1762              
1763             The following accessors may be used to extract diagnostic information
1764             from the EPP object:
1765              
1766             my $code = $epp->get_code;
1767             my $error = $epp->get_error;
1768             my $msg = $epp->get_message;
1769             my $reason = $epp->get_reason;
1770              
1771             The first three of these just provide an OO interface to $Code, $Error
1772             and $Message respectively. The user should use these in preference to
1773             the explicit variable names except in the specific instance of a login
1774             or connection failure when no epp object will be returned.
1775              
1776             =cut
1777              
1778             sub get_code {
1779 0     0 0   return $Code;
1780             }
1781              
1782             sub get_error {
1783 0     0 0   return $Error;
1784             }
1785              
1786             sub get_message {
1787 0     0 0   return $Message;
1788             }
1789              
1790             sub get_reason {
1791 0     0 0   my $self = shift;
1792 0           return $self->{'_reason'};
1793             }
1794              
1795             sub set_reason {
1796 0     0 0   my ($self, $response, @spec) = @_;
1797 0           my $reasonnode = $response->getNode ($spec[1], 'reason');
1798 0 0         my $reason = $reasonnode ? $reasonnode->firstChild->toString () : '';
1799 0           $reason .= $response->getElementsByLocalName ('msg')->get_node (1)->firstChild->toString ();
1800 0           $self->{'_reason'} = $reason;
1801              
1802 0           return $self->{'_reason'};
1803             }
1804              
1805             sub get_debug {
1806 0     0 0   my $self = shift;
1807 0           return $self->{debug};
1808             }
1809              
1810             sub set_debug {
1811 0     0 0   my ($self, $debug) = @_;
1812 0 0         croak "Debug must be whole number" unless $debug =~ /^\d+$/;
1813 0           $Debug = $debug;
1814 0 0         $self->{debug} = $Debug > 1 ? 1 : 0; # for parent
1815 0           return $Debug;
1816             }
1817              
1818             sub _send_frame {
1819 0     0     my ($self, $frame) = @_;
1820              
1821 0 0         warn "Frame to send = " . $frame->toString . "\n" if $Debug > 1;
1822 0           my $response = $self->request($frame);
1823 0 0         unless (defined $response) {
1824             # Critical error
1825 0           $Code = 0;
1826 0           $Error = "No response from server";
1827 0           warn $Error;
1828 0           $self->{connected} = 0;
1829 0           $self->{authenticated} = 0;
1830 0 0         if ($self->{reconnect}) {
1831             # Attempt to reconnect
1832 0           for (1 .. $self->{reconnect}) {
1833             $self->_go_connect and
1834 0 0         $self->login (@{$self->{login_params}});
  0            
1835 0 0         if ($self->{authenticated}) {
1836 0           $frame->clTRID->firstChild->setData ('');
1837 0           return $self->_send_frame ($frame);
1838             }
1839 0           warn "Re-connection attempt $_ of $self->{reconnect} failed.\n";
1840 0           sleep 2;
1841             }
1842             }
1843 0           return undef;
1844             }
1845 0 0         warn "Response = " . $response->toString . "\n" if $Debug > 1;
1846              
1847 0           $Code = $self->_get_response_code($response);
1848 0 0 0       if ($Code < 1000 or $Code > 1999) {
1849 0           $Error = sprintf("Server returned a %d code", $Code);
1850 0 0         warn $Error if $Debug;
1851 0           $Message = $response->msg;
1852             # Get the actual reason
1853 0           my $reason = $response->getElementsByTagName ('reason');
1854 0 0         $self->{'_reason'} = $#$reason >= 0 ? $reason->[0]->firstChild->toString () : undef;
1855 0           return undef;
1856             } else {
1857             # Clear the error
1858 0           $Error = '';
1859 0           $Message = '';
1860 0           $self->{'_reason'} = undef;
1861             }
1862 0           return $response;
1863             }
1864              
1865             =head1 TODO
1866              
1867             =encoding utf8
1868              
1869             =over
1870              
1871             =item * The poll, handshake, lock and reseller operations
1872             are not yet supported.
1873              
1874             =item * Much more extensive tests should be performed.
1875              
1876             =back
1877              
1878             =head1 See Also
1879              
1880             =over
1881              
1882             =item * L
1883              
1884             =item * Nominet's L
1885             Documentation|https://registrars.nominet.uk/uk-namespace/registration-and-domain-management/registration-systems/epp/>
1886              
1887             =item * The EPP RFCs: L,
1888             L,
1889             L and
1890             L.
1891              
1892             =back
1893              
1894             =head1 Author
1895              
1896             Pete Houston
1897              
1898             =head1 Licence
1899              
1900             This software is copyright © 2013-2023 by Pete Houston. It is released
1901             under the Artistic Licence (version 2) and the
1902             GNU General Public Licence (version 2).
1903              
1904             =cut
1905              
1906             1;