File Coverage

blib/lib/Net/DRI/Protocol/EPP/Extensions/SE/Extensions.pm
Criterion Covered Total %
statement 15 204 7.3
branch 0 126 0.0
condition 0 27 0.0
subroutine 5 21 23.8
pod 0 16 0.0
total 20 394 5.0


line stmt bran cond sub pod time code
1             ## Domain Registry Interface, .SE EPP Domain/Contact Extensions for Net::DRI
2             ## Contributed by Elias Sidenbladh and Ulrich Wisser from NIC SE
3             ##
4             ## Copyright (c) 2006,2008-2011,2013 Patrick Mevzek . All rights reserved.
5             ##
6             ## This file is part of Net::DRI
7             ##
8             ## Net::DRI is free software; you can redistribute it and/or modify
9             ## it under the terms of the GNU General Public License as published by
10             ## the Free Software Foundation; either version 2 of the License, or
11             ## (at your option) any later version.
12             ##
13             ## See the LICENSE file that comes with this distribution for more details.
14             ####################################################################################################
15              
16             package Net::DRI::Protocol::EPP::Extensions::SE::Extensions;
17              
18 1     1   1518 use strict;
  1         2  
  1         26  
19 1     1   4 use warnings;
  1         1  
  1         21  
20              
21 1     1   6 use Net::DRI::Util;
  1         1  
  1         17  
22 1     1   3 use Net::DRI::Exception;
  1         3  
  1         14  
23 1     1   4 use Net::DRI::Protocol::EPP::Util;
  1         2  
  1         2211  
24              
25             =pod
26              
27             =head1 NAME
28              
29             Net::DRI::Protocol::EPP::Extensions::SE::Extensions - .SE EPP Domain/Contact Extensions for Net::DRI
30              
31             =head1 DESCRIPTION
32              
33             Please see the README file for details.
34              
35             =head1 SUPPORT
36              
37             For now, support questions should be sent to:
38              
39             Enetdri@dotandco.comE
40              
41             Please also see the SUPPORT file in the distribution.
42              
43             =head1 SEE ALSO
44              
45             Ehttp://www.dotandco.com/services/software/Net-DRI/E
46              
47             =head1 AUTHOR
48              
49             Patrick Mevzek, Enetdri@dotandco.comE
50              
51             =head1 COPYRIGHT
52              
53             Copyright (c) 2006,2008-2011 Patrick Mevzek .
54             All rights reserved.
55              
56             This program is free software; you can redistribute it and/or modify
57             it under the terms of the GNU General Public License as published by
58             the Free Software Foundation; either version 2 of the License, or
59             (at your option) any later version.
60              
61             See the LICENSE file that comes with this distribution for more details.
62              
63             =cut
64              
65             ###################################################################################################
66              
67             sub register_commands {
68 0     0 0   my ( $class, $version ) = @_;
69 0           my $domain = {
70             info => [ undef, \&domain_parse ],
71             create => [ undef, \&domain_parse ],
72             update => [ \&domain_update, \&domain_parse ],
73             transfer_request => [ \&domain_transfer, \&domain_transfer_parse ],
74             notifyDelete => [ undef, \&delete_parse ],
75             };
76 0           my $contact = {
77             info => [ undef, \&contact_parse ],
78             create => [ \&contact_create, undef ],
79             update => [ \&contact_update, undef ],
80             transfer_request => [ undef, \&contact_transfer_parse ],
81             };
82 0           my $host = {
83             info => [ undef, \&host_parse ],
84             transfer_request => [ undef, \&host_transfer_parse ],
85             };
86 0           my %session=(
87             'connect' => [ undef, \&parse_greeting ],
88             'noop' => [ undef, \&parse_greeting ],
89             );
90 0           return { 'domain' => $domain, 'contact' => $contact, 'host' => $host, session => \%session };
91             }
92              
93             sub capabilities_add {
94 0     0 0   return ( [ 'domain_update', 'client_delete', [ 'set', ] ], );
95             }
96             ###################################################################################################
97              
98             ## This was previously basically Extensions/SE/Message/_get_content
99             ## but since anyway it should be done properly by walking the XML tree inside of poking like this,
100             ## put it here to remove the SE/Message module
101             sub find_node
102             {
103 0     0 0   my ($mes,$nstag,$nodename)=@_;
104 0           my $node=$mes->node_resdata();
105 0 0         return unless defined $node;
106 0           my $ns=$mes->ns($nstag);
107 0 0 0       $ns=$nstag unless defined $ns && $ns;
108 0           my @tmp=$node->getElementsByTagNameNS($ns,$nodename);
109 0 0         return unless @tmp;
110 0           return $tmp[0];
111             }
112              
113             sub get_notify {
114 0     0 0   my $mes = shift;
115 0           my $ns=$mes->ns('iis');
116             # only one of these will be given, but we can't know which in advance
117 0 0         return 'create' if defined find_node($mes,$ns,'createNotify');
118 0 0         return 'update' if defined find_node($mes,$ns,'updateNotify');
119 0 0         return 'delete' if defined find_node($mes,$ns,'deleteNotify');
120 0 0         return 'transfer' if defined find_node($mes,$ns,'transferNotify');
121              
122             # done, no notify found
123 0           return;
124             }
125              
126             ##################################################################################################
127             ########### Query commands
128              
129             # parse domain info
130             sub domain_parse {
131 0     0 0   my ( $po, $otype, $oaction, $oname, $rinfo ) = @_;
132 0           my $mes = $po->message();
133 0 0         return unless $mes->is_success();
134              
135             # only domain info should be parsed
136 0 0 0       return if ( ( !defined $otype ) || ( $otype ne 'domain' ) );
137              
138             # check for notify
139 0           my $notify = get_notify($mes);
140 0 0         $rinfo->{domain}->{$oname}->{notify} = $notify if defined $notify;
141              
142             # get from
143 0           my $infData = $mes->get_extension( $mes->ns('iis'), 'infData' );
144 0 0         return unless defined $infData;
145              
146             # parse deleteDate (optional)
147 0           foreach my $el ( $infData->getElementsByTagNameNS( $mes->ns('iis'), 'delDate' ) ) {
148 0           $rinfo->{domain}->{$oname}->{delDate} = $po->parse_iso8601( $el->textContent() );
149             }
150              
151             # parse deactDate (optional)
152 0           foreach my $el ( $infData->getElementsByTagNameNS( $mes->ns('iis'), 'deactDate' ) ) {
153 0           $rinfo->{domain}->{$oname}->{deactDate} = $po->parse_iso8601( $el->textContent() );
154             }
155              
156             # parse relDate (optional)
157 0           foreach my $el ( $infData->getElementsByTagNameNS( $mes->ns('iis'), 'relDate' ) ) {
158 0           $rinfo->{domain}->{$oname}->{relDate} = $po->parse_iso8601( $el->textContent() );
159             }
160              
161             # parse state
162 0           foreach my $el ( $infData->getElementsByTagNameNS( $mes->ns('iis'), 'state' ) ) {
163 0           $rinfo->{domain}->{$oname}->{state} = $el->textContent();
164             }
165              
166             # parse clientDelete
167 0           foreach my $el ( $infData->getElementsByTagNameNS( $mes->ns('iis'), 'clientDelete' ) ) {
168 0           $rinfo->{domain}->{$oname}->{clientDelete} = $el->textContent();
169             }
170              
171             # done
172 0           return;
173             }
174              
175             # parse contact info
176             sub contact_parse {
177 0     0 0   my ( $po, $otype, $oaction, $oname, $rinfo ) = @_;
178 0           my $mes = $po->message();
179 0 0         return unless $mes->is_success();
180              
181             # only contact info should be parsed
182 0 0 0       return if ( ( !defined $otype ) || ( $otype ne 'contact' ) );
183              
184             # check for notify
185 0           my $notify = get_notify($mes);
186 0 0         $rinfo->{contact}->{$oname}->{notify} = $notify if defined $notify;
187              
188             # get from
189 0           my $result = $mes->get_extension( $mes->ns('iis'), 'infData' );
190 0 0         return unless defined $result;
191              
192             # parse orgno (mandatory)
193 0           foreach my $el ( $result->getElementsByTagNameNS( $mes->ns('iis'), 'orgno' ) ) {
194 0           $rinfo->{contact}->{$oname}->{self}->orgno( $el->textContent() );
195             }
196              
197             # parse vatno (optional)
198 0           foreach my $el ( $result->getElementsByTagNameNS( $mes->ns('iis'), 'vatno' ) ) {
199 0           $rinfo->{contact}->{$oname}->{self}->vatno( $el->textContent() );
200             }
201              
202             # done
203 0           return;
204             }
205              
206             sub host_parse {
207 0     0 0   my ( $po, $otype, $oaction, $oname, $rinfo ) = @_;
208 0           my $mes = $po->message();
209 0 0         return unless $mes->is_success();
210              
211             # only contact info should be parsed
212 0 0 0       return if ( ( !defined $otype ) || ( $otype ne 'host' ) );
213              
214             # check for notify
215 0           my $notify = get_notify($mes);
216 0 0         $rinfo->{host}->{$oname}->{notify} = $notify if defined $notify;
217              
218             # done
219 0           return;
220             }
221              
222             # parse
223             sub domain_transfer_parse {
224 0     0 0   my ( $po, $otype, $oaction, $oname, $rinfo ) = @_;
225 0           my $mes = $po->message();
226 0 0         return unless $mes->is_success();
227              
228 0           my $trndata = find_node($mes,$mes->ns('domain'),'infData');
229 0 0         $trndata = find_node($mes,$mes->ns('domain'), 'trnData' ) if !defined($trndata);
230 0 0         return unless defined $trndata;
231              
232 0           foreach my $el (Net::DRI::Util::xml_list_children($trndata))
233             {
234 0           my ($name,$c)=@$el;
235 0 0         if ( $name eq 'name' ) {
    0          
    0          
236 0           $oname = $c->textContent();
237 0           $rinfo->{domain}->{$oname}->{action} = 'transfer';
238 0           $rinfo->{domain}->{$oname}->{exist} = 1;
239             }
240             elsif ( $name =~ m/^(trStatus|reID|acID)$/ ) {
241 0           $rinfo->{domain}->{$oname}->{$1} = $c->textContent();
242             }
243             elsif ( $name =~ m/^(reDate|acDate|exDate)$/ ) {
244 0           $rinfo->{domain}->{$oname}->{$1} = $po->parse_iso8601( $c->textContent() );
245             }
246             }
247              
248             # check for notify
249 0           my $notify = get_notify($mes, 'domain_transfer_parse');
250 0 0         $rinfo->{domain}->{$oname}->{notify} = $notify if defined $notify;
251              
252             # done
253 0           return;
254             }
255              
256              
257             # parse
258             # copied from Net::DRI::Protocol::EPP::Core::Domain
259             sub host_transfer_parse {
260 0     0 0   my ( $po, $otype, $oaction, $oname, $rinfo ) = @_;
261 0           my $mes = $po->message();
262 0 0         return unless $mes->is_success();
263              
264 0           my $trndata = find_node($mes,$mes->ns('host'), 'infData' );
265 0 0         $trndata = find_node($mes,$mes->ns('host'), 'trnData' ) if !defined($trndata);
266 0 0         return unless defined $trndata;
267              
268 0           foreach my $el (Net::DRI::Util::xml_list_children($trndata))
269             {
270 0           my ($name,$c)=@$el;
271 0 0         if ( $name eq 'name' ) {
    0          
    0          
272 0           $oname = $c->textContent();
273 0           $rinfo->{host}->{$oname}->{action} = 'transfer';
274 0           $rinfo->{host}->{$oname}->{exist} = 1;
275             }
276             elsif ( $name =~ m/^(trStatus|reID|acID)$/ ) {
277 0           $rinfo->{host}->{$oname}->{$1} = $c->textContent();
278             }
279             elsif ( $name =~ m/^(reDate|acDate|exDate)$/ ) {
280 0           $rinfo->{host}->{$oname}->{$1} = $po->parse_iso8601( $c->textContent() );
281             }
282             }
283              
284             # check for notify
285 0           my $notify = get_notify($mes);
286 0 0         $rinfo->{host}->{$oname}->{notify} = $notify if defined $notify;
287              
288             # done
289 0           return;
290             }
291              
292             sub contact_transfer_parse {
293 0     0 0   my ( $po, $otype, $oaction, $oname, $rinfo ) = @_;
294 0           my $mes = $po->message();
295 0 0         return unless $mes->is_success();
296              
297 0           my $trndata = find_node($mes,$mes->ns('contact'), 'infData' );
298 0 0         $trndata = find_node($mes,$mes->ns('contact'), 'trnData' ) if !defined($trndata);
299 0 0         return unless defined $trndata;
300              
301 0           foreach my $el (Net::DRI::Util::xml_list_children($trndata))
302             {
303 0           my ($name,$c)=@$el;
304 0 0         if ( $name eq 'id' ) {
    0          
    0          
305 0           $oname = $c->textContent();
306 0           $rinfo->{contact}->{$oname}->{action} = 'transfer';
307 0           $rinfo->{contact}->{$oname}->{exist} = 1;
308             }
309             elsif ( $name =~ m/^(trStatus|reID|acID)$/ ) {
310 0           $rinfo->{contact}->{$oname}->{$1} = $c->textContent();
311             }
312             elsif ( $name =~ m/^(reDate|acDate|exDate)$/ ) {
313 0           $rinfo->{contact}->{$oname}->{$1} = $po->parse_iso8601( $c->textContent() );
314             }
315             }
316              
317             # check for notify
318 0           my $notify = get_notify($mes);
319 0 0         $rinfo->{contact}->{$oname}->{notify} = $notify if defined $notify;
320              
321             # done
322 0           return;
323             }
324              
325             # parse delete message
326             sub delete_parse {
327 0     0 0   my ( $po, $otype, $oaction, $oname, $rinfo ) = @_;
328 0           my $nametag;
329 0           my $mes = $po->message();
330 0 0         return unless $mes->is_success();
331              
332             # check for notify
333 0           my $notify = get_notify($mes);
334 0 0 0       return if ( ( !defined $notify ) || ( ( $notify ne 'delete' ) && ( $notify ne 'transfer' ) ) );
      0        
335              
336             # check for host
337 0           my $host = find_node($mes,$mes->ns('host'), 'name' );
338 0 0         if ( defined $host ) {
339 0           $oname = $host->textContent();
340 0           $otype = 'host';
341             }
342              
343             # check for contact
344 0           my $contact = find_node($mes, $mes->ns('contact'), 'id' );
345 0 0         if ( defined $contact ) {
346 0           $oname = $contact->textContent();
347 0           $otype = 'contact';
348             }
349              
350             # check for domain
351 0           my $domain = find_node($mes, $mes->ns('domain'), 'name' );
352 0 0         if ( defined $domain ) {
353 0           $oname = $domain->textContent();
354 0           $otype = 'domain';
355             }
356              
357 0           $rinfo->{$otype}->{$oname}->{notify} = $notify;
358 0           $rinfo->{$otype}->{$oname}->{action} = $notify;
359 0           $rinfo->{$otype}->{$oname}->{exist} = 0;
360              
361             # done
362 0           return;
363             }
364              
365             # domain update command extension
366             sub domain_update {
367 0     0 0   my ( $epp, $domain, $rd ) = @_;
368 0           my @data = ();
369 0           my $mes = $epp->message();
370              
371             # iis:clientDelete
372 0 0         if ( exists $rd->{client_delete} ) {
373 0 0         Net::DRI::Exception::usererr_invalid_parameters("client_delete can only be '1' or '0'") if ( $rd->{client_delete}[2] !~ /^(0|1)$/ );
374 0           push @data, [ 'iis:clientDelete', $rd->{client_delete}[2] ];
375             }
376              
377             # only add extension if any data gets added
378 0 0         return unless @data;
379              
380             # create
381 0           my $iis_extension = $mes->command_extension_register('iis','update');
382              
383             # now add extension to message
384 0           $mes->command_extension( $iis_extension, \@data );
385              
386             # done
387 0           return;
388             }
389              
390             sub domain_transfer {
391 0     0 0   my ( $epp, $domain, $rd ) = @_;
392 0           my @data = ();
393 0           my $mes = $epp->message();
394              
395             # new nameservers (optional)
396 0 0         push @data, [ 'iis:ns', map { [ 'iis:hostObj', $_ ] } $rd->{ns}->get_names() ] if Net::DRI::Util::has_ns($rd);
  0            
397              
398             # only add body if any data gets added
399 0 0         return unless @data;
400              
401             # create
402 0           my $iis_extension = $mes->command_extension_register('iis','transfer');
403              
404             # now add extension to message
405 0           $mes->command_extension( $iis_extension, \@data );
406              
407             # done
408 0           return;
409             }
410              
411             # contact create command extension
412             sub contact_create {
413 0     0 0   my ( $epp, $contact, $rd ) = @_;
414 0           my @data = ();
415 0           my $mes = $epp->message();
416              
417             # iis:orgno (mandatory)
418 0           my $orgno;
419 0 0         $orgno = $rd->{orgno} if exists( $rd->{orgno} );
420 0 0         $orgno = $contact->{orgno} if exists( $contact->{orgno} );
421 0 0         $orgno = $contact->orgno if $contact->can('orgno');
422              
423 0 0         Net::DRI::Exception::usererr_insufficient_parameters('Attribute orgno must exist') unless defined $orgno;
424 0           push @data, [ 'iis:orgno', $orgno ];
425              
426             # iis:vatno (optional)
427 0           my $vatno;
428 0 0         $vatno = $rd->{orgno} if exists( $rd->{vatno} );
429 0 0         $vatno = $contact->{vatno} if exists( $contact->{vatno} );
430 0 0         $vatno = $contact->vatno if $contact->can('vatno');
431 0 0 0       if ( exists( $rd->{vatno} ) && $vatno ) {
432 0           push @data, [ 'iis:vatno', $vatno ];
433             }
434              
435             # only add extension if any data gets added
436 0 0         return unless @data;
437              
438             # create
439 0           my $iis_extension = $mes->command_extension_register('iis','create');
440              
441             # now add extension to message
442 0           $mes->command_extension( $iis_extension, \@data );
443              
444             # done
445 0           return;
446             }
447              
448             # contact update command extension
449             sub contact_update {
450 0     0 0   my ( $epp, $contact, $rd ) = @_;
451 0           my @data = ();
452 0           my $mes = $epp->message();
453              
454             # get the new contact information
455 0           my $newc = $rd->set('info');
456 0 0 0       return unless defined $newc && ref $newc;
457              
458             # iis:orgno (mandatory)
459 0 0         Net::DRI::Exception::usererr_insufficient_parameters('Attribute orgno can not be updated') if exists( $newc->{orgno} );
460              
461             # iis:vatno (optional)
462 0 0 0       if ( exists( $newc->{vatno} ) && defined $newc->{vatno} ) {
463 0           push @data, [ 'iis:vatno', $newc->{vatno} ];
464             }
465              
466             # only add extension if any data gets added
467 0 0         return unless @data;
468              
469             # create
470 0           my $iis_extension = $mes->command_extension_register('iis','update');
471              
472             # now add extension to message
473 0           $mes->command_extension( $iis_extension, \@data );
474              
475             # done
476 0           return;
477             }
478              
479             ####################################################################################################
480             ## Session commands, adapt to server greeting
481              
482             sub parse_greeting
483             {
484 0     0 0   my ($po,$otype,$oaction,$oname,$rinfo)=@_;
485 0           my $mes=$po->message();
486              
487 0 0         return unless defined $mes->node_greeting(); ## only work here for true greeting reply handling, not for all polling responses !
488              
489 0           $po->switch_to_highest_namespace_version('iis');
490 0           return;
491             }
492              
493             ####################################################################################################
494             1;