File Coverage

blib/lib/Net/DRI/Protocol/EPP/Extensions/CAT/Domain.pm
Criterion Covered Total %
statement 15 149 10.0
branch 0 120 0.0
condition 0 57 0.0
subroutine 5 16 31.2
pod 0 11 0.0
total 20 353 5.6


line stmt bran cond sub pod time code
1             ## Domain Registry Interface, .CAT Domain EPP extension commands
2             ##
3             ## Copyright (c) 2006-2008,2012-2014 Patrick Mevzek . All rights reserved.
4             ##
5             ## This file is part of Net::DRI
6             ##
7             ## Net::DRI is free software; you can redistribute it and/or modify
8             ## it under the terms of the GNU General Public License as published by
9             ## the Free Software Foundation; either version 2 of the License, or
10             ## (at your option) any later version.
11             ##
12             ## See the LICENSE file that comes with this distribution for more details.
13             ####################################################################################################
14              
15             package Net::DRI::Protocol::EPP::Extensions::CAT::Domain;
16              
17 1     1   965 use strict;
  1         1  
  1         28  
18 1     1   3 use warnings;
  1         1  
  1         22  
19              
20 1     1   4 use Email::Valid;
  1         1  
  1         17  
21 1     1   2 use Net::DRI::Util;
  1         2  
  1         15  
22 1     1   4 use Net::DRI::Exception;
  1         1  
  1         1642  
23              
24             =pod
25              
26             =head1 NAME
27              
28             Net::DRI::Protocol::EPP::Extensions::CAT::Domain - .CAT EPP Domain extension commands for Net::DRI
29              
30             =head1 DESCRIPTION
31              
32             Please see the README file for details.
33              
34             =head1 SUPPORT
35              
36             For now, support questions should be sent to:
37              
38             Enetdri@dotandco.comE
39              
40             Please also see the SUPPORT file in the distribution.
41              
42             =head1 SEE ALSO
43              
44             Ehttp://www.dotandco.com/services/software/Net-DRI/E
45              
46             =head1 AUTHOR
47              
48             Patrick Mevzek, Enetdri@dotandco.comE
49              
50             =head1 COPYRIGHT
51              
52             Copyright (c) 2006-2008,2012-2014 Patrick Mevzek .
53             All rights reserved.
54              
55             This program is free software; you can redistribute it and/or modify
56             it under the terms of the GNU General Public License as published by
57             the Free Software Foundation; either version 2 of the License, or
58             (at your option) any later version.
59              
60             See the LICENSE file that comes with this distribution for more details.
61              
62             =cut
63              
64             ####################################################################################################
65              
66             sub register_commands
67             {
68 0     0 0   my ($class,$version)=@_;
69 0           my %tmp=(
70             create => [ \&create, undef ],
71             update => [ \&update, undef ],
72             info => [ undef, \&info_parse ],
73             );
74              
75 0           return { 'domain' => \%tmp };
76             }
77              
78             ####################################################################################################
79              
80             sub build_command_extension
81             {
82 0     0 0   my ($mes,$epp,$tag)=@_;
83 0           return $mes->command_extension_register($tag,sprintf('xmlns:dx="%s" xsi:schemaLocation="%s %s"',$mes->nsattrs('puntcat_domain')));
84             }
85              
86             sub add_name_variant
87             {
88 0     0 0   my ($d)=@_;
89 0           my @n;
90              
91 0 0         foreach my $n ((ref($d) eq 'ARRAY')? @{$d} : ($d))
  0            
92             {
93 0 0         Net::DRI::Exception::usererr_invalid_parameters($n.' in name_variant attribute must be an XML token between 1 & 255 chars in length') unless Net::DRI::Util::xml_is_token($n,1,255);
94 0           push @n,['dx:nameVariant',$n];
95             }
96              
97 0           return @n;
98             }
99              
100             sub add_lang
101             {
102 0     0 0   my ($d)=@_;
103 0 0 0       Net::DRI::Exception::usererr_invalid_parameters('lang attribute must be an XML language') unless (($d eq '') || Net::DRI::Util::xml_is_language($d));
104 0           return ['dx:language',$d];
105             }
106              
107             sub add_maintainer
108             {
109 0     0 0   my ($d)=@_;
110 0 0         Net::DRI::Exception::usererr_invalid_parameters('maintainer attribute must be an XML token not more than 128 chars long') unless Net::DRI::Util::xml_is_token($d,undef,128);
111 0           return ['dx:maintainer',$d];
112             }
113              
114             sub add_intended_use
115             {
116 0     0 0   my ($d)=@_;
117 0 0 0       Net::DRI::Exception::usererr_invalid_parameters('intended_use must be a string between 1 and 1000 chars long') unless (''.$d && (length $d <= 1000));
118 0           return ['dx:intendedUse',$d];
119             }
120              
121             sub add_disclose
122             {
123 0     0 0   my ($rd)=@_;
124 0 0         Net::DRI::Exception::usererr_invalid_parameters('registrant_disclosure must be a ref hash') unless ref $rd eq 'HASH';
125 0 0         Net::DRI::Exception::usererr_invalid_parameters('registrant_disclosure must have a type key') unless exists $rd->{type};
126 0 0         Net::DRI::Exception::usererr_invalid_parameters('registrant_disclosure type key must have value "natural" or "legal"') unless $rd->{type}=~m/^(?:natural|legal)$/;
127 0 0         if ($rd->{type} eq 'natural')
128             {
129 0 0         Net::DRI::Exception::usererr_invalid_parameters('registrant_disclosure must have a disclose key when type=natural') unless exists $rd->{disclose};
130 0 0         return ['dx:disclosure',['dx:natural',{disclose => $rd->{disclose} ? 'true' : 'false' }]];
131             } else
132             {
133 0           return ['dx:disclosure',['dx:legal']];
134             }
135             }
136              
137             sub add_puntcat_extension
138             {
139 0     0 0   my ($rd)=@_;
140 0           my @n;
141 0 0 0       return @n unless (defined $rd && ref $rd eq 'HASH' && keys %$rd);
      0        
142              
143 0 0 0       if (exists $rd->{name_variant} && defined $rd->{name_variant})
144             {
145 0           push @n,add_name_variant($rd->{name_variant});
146             }
147              
148 0 0 0       push @n,add_lang($rd->{lang}) if (exists $rd->{lang} && defined $rd->{lang});
149 0 0 0       push @n,add_maintainer($rd->{maintainer}) if (exists $rd->{maintainer} && defined $rd->{maintainer});
150              
151 0 0 0       Net::DRI::Exception::usererr_insufficient_parameters('ens block is mandatory, since intendeduse are mandatory') unless (exists $rd->{ens} && defined $rd->{ens} && (ref $rd->{ens} eq 'HASH'));
      0        
152 0           my %ens=%{$rd->{ens}};
  0            
153 0           my @ens;
154              
155 0 0 0       if (exists $ens{auth} && defined $ens{auth})
156             {
157 0 0         my %auth=(ref $ens{auth} eq 'HASH')? (key => $ens{auth}->{key}, id => $ens{auth}->{id} ) : (id => $ens{auth});
158 0 0 0       Net::DRI::Exception::usererr_insufficient_parameters('in ens auth block, id is mandatory') unless (exists $auth{id} && defined $auth{id});
159 0 0         Net::DRI::Exception::usererr_invalid_parameters('id in ens auth block must be XML token between 1 and 20 chars long') if !Net::DRI::Util::xml_is_token($auth{id},1,20);
160 0 0 0       Net::DRI::Exception::usererr_invalid_parameters('key in ens auth block must be XML token between 1 and 20 chars long') if (exists $auth{key} && !Net::DRI::Util::xml_is_token($auth{key},1,20));
161 0           push @ens,['dx:auth',\%auth];
162             }
163              
164 0 0 0       if (exists $ens{sponsor} && defined $ens{sponsor})
165             {
166 0           my @e;
167 0 0         foreach my $e ((ref $ens{sponsor} eq 'ARRAY')? @{$ens{sponsor}} : ($ens{sponsor}))
  0            
168             {
169 0 0 0       Net::DRI::Exception::usererr_invalid_parameters("sponsor value $e in ens block must be a valid email address") unless (defined($e) && Net::DRI::Util::xml_is_token($e,1,undef) && Email::Valid->rfc822($e));
      0        
170 0           push @e,['dx:sponsor',$e];
171             }
172 0 0 0       Net::DRI::Exception::usererr_invalid_parameters('there must be either 1 or 3 sponsors') unless (@e==1 || @e==3);
173 0           push @ens,['dx:sponsoring',@e];
174             }
175              
176 0 0 0       if (exists $ens{ref_url} && defined $ens{ref_url})
177             {
178 0 0         Net::DRI::Exception::usererr_invalid_parameters('ref_url in ens auth block must be XML token between 1 and 255 chars long') unless Net::DRI::Util::xml_is_token($ens{ref_url},1,255);
179 0           push @ens,['dx:refURL',$ens{ref_url}];
180             }
181              
182 0 0 0       if (exists $ens{registration_type} && defined $ens{registration_type})
183             {
184 0 0         Net::DRI::Exception::usererr_invalid_parameters('registration_type in ens auth block must be XML token between 1 and 128 chars long') unless Net::DRI::Util::xml_is_token($ens{registration_type},1,128);
185 0           push @ens,['dx:registrationType',$ens{registration_type}];
186             }
187              
188 0 0 0       Net::DRI::Exception::usererr_insufficient_parameters('intended_use in ens auth block is mandatory') unless (exists $ens{intended_use} && defined $ens{intended_use});
189 0           push @ens,add_intended_use($ens{intended_use});
190              
191 0 0         push @n,['dx:ens',@ens] if @ens;
192              
193 0 0         push @n,add_disclose($rd->{registrant_disclosure}) if Net::DRI::Util::has_key($rd,'registrant_disclosure');
194 0           return @n;
195             }
196              
197             sub create
198             {
199 0     0 0   my ($epp,$domain,$rd)=@_;
200 0           my $mes=$epp->message();
201              
202 0           my @n=add_puntcat_extension($rd);
203 0 0         return unless @n;
204              
205 0           my $eid=build_command_extension($mes,$epp,'dx:create');
206 0           $mes->command_extension($eid,\@n);
207 0           return;
208             }
209              
210             sub update
211             {
212 0     0 0   my ($epp,$domain,$todo)=@_;
213 0           my $mes=$epp->message();
214 0           my (@tmp,@n);
215              
216 0 0         if ($todo->types('name_variant'))
217             {
218 0 0         Net::DRI::Exception->die(0,'protocol/EPP',11,'Only name_variant add/del available for domain') if grep { ! /^(?:add|del)$/ } $todo->types('name_variant');
  0            
219              
220 0           @tmp=add_name_variant($todo->add('name_variant'));
221 0 0         push @n,['dx:add',@tmp] if @tmp;
222 0           @tmp=add_name_variant($todo->del('name_variant'));
223 0 0         push @n,['dx:rem',@tmp] if @tmp;
224             }
225              
226 0           @tmp=();
227              
228 0 0         if ($todo->types('lang'))
229             {
230 0 0         Net::DRI::Exception->die(0,'protocol/EPP',11,'Only lang set available for domain') if grep { $_ ne 'set' } $todo->types('lang');
  0            
231 0           push @tmp,add_lang($todo->set('lang'));
232             }
233 0 0         if ($todo->types('maintainer'))
234             {
235 0 0         Net::DRI::Exception->die(0,'protocol/EPP',11,'Only maintainer set available for domain') if grep { $_ ne 'set' } $todo->types('maintainer');
  0            
236 0           push @tmp,add_maintainer($todo->set('maintainer'));
237             }
238 0 0         if ($todo->types('intended_use'))
239             {
240 0 0         Net::DRI::Exception->die(0,'protocol/EPP',11,'Only intended_use set available for domain') if grep { $_ ne 'set' } $todo->types('intended_use');
  0            
241 0           push @tmp,add_intended_use($todo->set('intended_use'));
242             }
243 0 0         if ($todo->types('registrant_disclosure'))
244             {
245 0 0         Net::DRI::Exception->die(0,'protocol/EPP',11,'Only registrant_disclosure set available for domain') if grep { $_ ne 'set' } $todo->types('registrant_disclosure');
  0            
246 0           push @tmp,add_disclose($todo->set('registrant_disclosure'));
247             }
248 0 0         push @n,['dx:chg',@tmp] if @tmp;
249              
250 0 0         return unless @n;
251 0           my $eid=build_command_extension($mes,$epp,'dx:update');
252 0           $mes->command_extension($eid,\@n);
253 0           return;
254             }
255              
256             sub info_parse
257             {
258 0     0 0   my ($po,$otype,$oaction,$oname,$rinfo)=@_;
259 0           my $mes=$po->message();
260 0 0         return unless $mes->is_success();
261              
262 0           my $infdata=$mes->get_extension('puntcat_domain','infData');
263 0 0         return unless $infdata;
264              
265 0           foreach my $el (Net::DRI::Util::xml_list_children($infdata))
266             {
267 0           my ($name,$c)=@$el;
268 0 0         if ($name eq 'nameVariant')
    0          
    0          
    0          
    0          
269             {
270 0           push @{$rinfo->{domain}->{$oname}->{name_variant}},$c->textContent();
  0            
271             } elsif ($name eq 'language')
272             {
273 0           $rinfo->{domain}->{$oname}->{lang}=$c->textContent();
274             } elsif ($name eq 'maintainer')
275             {
276 0           $rinfo->{domain}->{$oname}->{maintainer}=$c->textContent();
277             } elsif ($name eq 'ens')
278             {
279 0           my %ens;
280 0           foreach my $ell (Net::DRI::Util::xml_list_children($c))
281             {
282 0           my ($name2,$cc)=@$ell;
283 0 0         if ($name2 eq 'auth')
    0          
    0          
    0          
    0          
284             {
285 0           $ens{auth}={ id => $cc->getAttribute('id') };
286             } elsif ($name2 eq 'sponsoring')
287             {
288 0           $ens{sponsor}=[ map { $_->textContent() } $cc->getChildrenByTagNameNS($mes->ns('puntcat_domain'),'sponsor') ];
  0            
289             } elsif ($name2 eq 'refURL')
290             {
291 0           $ens{ref_url}=$cc->textContent();
292             } elsif ($name2 eq 'registrationType')
293             {
294 0           $ens{registration_type}=$cc->textContent();
295             } elsif ($name2 eq 'intendedUse')
296             {
297 0           $ens{intended_use}=$cc->textContent();
298             }
299             }
300 0           $rinfo->{domain}->{$oname}->{ens}=\%ens;
301             } elsif ($name eq 'disclosure')
302             {
303 0           my @d=@{(Net::DRI::Util::xml_list_children($c))[0]};
  0            
304 0           my %e;
305 0           $e{type}=$d[0]; ## natural or legal
306 0 0         $e{disclose}=Net::DRI::Util::xml_parse_boolean($d[1]->getAttribute('disclose')) if ($e{type} eq 'natural');
307 0           $rinfo->{domain}->{$oname}->{registrant_disclosure}=\%e;
308             }
309             }
310 0           return;
311             }
312              
313             ####################################################################################################
314             1;