File Coverage

blib/lib/Net/DRI/Protocol/EPP/Util.pm
Criterion Covered Total %
statement 18 212 8.4
branch 0 104 0.0
condition 0 73 0.0
subroutine 6 23 26.0
pod 0 16 0.0
total 24 428 5.6


line stmt bran cond sub pod time code
1             ## Domain Registry Interface, EPP Protocol Utility functions
2             ##
3             ## Copyright (c) 2009,2010,2015 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::Util;
16              
17 1     1   890 use utf8;
  1         2  
  1         5  
18 1     1   29 use strict;
  1         1  
  1         16  
19 1     1   4 use warnings;
  1         1  
  1         32  
20 1     1   4 use feature 'state';
  1         2  
  1         82  
21              
22 1     1   4 use Net::DRI::Util;
  1         1  
  1         16  
23 1     1   3 use Net::DRI::Exception;
  1         1  
  1         2717  
24              
25             ####################################################################################################
26              
27             sub parse_node_status
28             {
29 0     0 0   my ($node)=@_;
30 0           my %tmp=( name => $node->getAttribute('s') );
31 0           ($tmp{lang},$tmp{msg})=parse_node_msg($node);
32 0           return \%tmp;
33             }
34              
35             sub parse_node_msg
36             {
37 0     0 0   my ($node)=@_; ## eppcom:msgType
38 0   0       return (($node->getAttribute('lang') || 'en'),$node->textContent() || '');
      0        
39             }
40              
41             ## Try to enhance parsing of common cases
42             sub parse_node_value
43             {
44 0     0 0   my ($n)=@_;
45 0           my $t=$n->toString();
46 0           $t=~s!^(.+?)$!$1!;
47 0           $t=~s/^\s+//;
48 0           $t=~s/\s+$//;
49 0           $t=~s!^(.+)$!$1!;
50 0           $t=~s!^$!!;
51 0           return $t;
52             }
53              
54             sub parse_node_result
55             {
56 0     0 0   my ($node,$ns,$from)=@_;
57 0 0         $from='eppcom' unless defined $from;
58 0           my ($lang,$msg)=parse_node_msg($node->getChildrenByTagNameNS($ns,'msg')->get_node(1));
59              
60 0           my @i;
61 0           foreach my $el (Net::DRI::Util::xml_list_children($node)) ## or nodes, all optional
62             {
63 0           my ($name,$c)=@$el;
64 0 0         if ($name eq 'extValue')
    0          
65             {
66 0           my @c=Net::DRI::Util::xml_list_children($c); ## we need to use that, instead of directly firstChild/lastChild because we want only element nodes, not whitespaces if there
67 0           my $c1=$c[0]->[1]; ## node
68 0           my $c2=$c[-1]->[1]; ## node
69 0           my ($ll,$lt)=parse_node_msg($c2);
70 0           my $v=parse_node_value($c1);
71 0 0         push @i,{ from => $from.':extValue', type => $v=~m/^ $v, lang => $ll, reason => $lt };
72             } elsif ($name eq 'value')
73             {
74 0           my $v=parse_node_value($c);
75 0 0         push @i,{ from => $from.':value', type => $v=~m/^ $v };
76             }
77             }
78              
79 0           return { code => $node->getAttribute('code'), message => $msg, lang => $lang, extra_info => \@i };
80             }
81              
82             ####################################################################################################
83              
84             sub domain_build_command
85             {
86 0     0 0   my ($msg,$command,$domain,$domainattr)=@_;
87 0 0         my @dom=ref $domain ? @$domain : ($domain);
88 0 0         Net::DRI::Exception->die(1,'protocol/EPP',2,'Domain name needed') unless @dom;
89 0           foreach my $d (@dom)
90             {
91 0 0 0       Net::DRI::Exception->die(1,'protocol/EPP',2,'Domain name needed') unless defined $d && $d;
92 0 0         Net::DRI::Exception->die(1,'protocol/EPP',10,'Invalid domain name: '.$d) unless Net::DRI::Util::xml_is_token($d,1,255);
93             }
94              
95 0 0         my $tcommand=ref $command ? $command->[0] : $command;
96 0           $msg->command([$command,'domain:'.$tcommand,sprintf('xmlns:domain="%s" xsi:schemaLocation="%s %s"',$msg->nsattrs('domain'))]);
97              
98 0           my @d=map { ['domain:name',$_,$domainattr] } @dom;
  0            
99 0           return @d;
100             }
101              
102             sub domain_build_authinfo
103             {
104 0     0 0   my ($epp,$rauth,$isupdate)=@_;
105 0 0 0       return ['domain:authInfo',['domain:null']] if ((! defined $rauth->{pw} || $rauth->{pw} eq '') && $epp->{usenullauth} && (defined($isupdate) && $isupdate));
      0        
      0        
      0        
106 0 0         return ['domain:authInfo',['domain:pw',$rauth->{pw},exists($rauth->{roid})? { 'roid' => $rauth->{roid} } : undef]];
107             }
108              
109             sub build_tel
110             {
111 0     0 0   my ($name,$tel)=@_;
112 0 0         if ($tel=~m/^(\S+)x(\S+)$/)
113             {
114 0           return [$name,$1,{x=>$2}];
115             } else
116             {
117 0           return [$name,$tel];
118             }
119             }
120              
121             sub parse_tel
122             {
123 0     0 0   my $node=shift;
124 0   0       my $ext=$node->getAttribute('x') || '';
125 0           my $num=$node->textContent();
126 0 0         $num.='x'.$ext if $ext;
127 0           return $num;
128             }
129              
130             sub build_period
131             {
132 0     0 0   my ($dtd,$ns)=@_;
133 0   0       $ns//='domain';
134 0           my ($y,$m)=$dtd->in_units('years','months'); ## all values are integral, but may be negative
135 0 0 0       ($y,$m)=(0,$m+12*$y) if ($y && $m);
136 0           my ($v,$u);
137 0 0         if ($y)
138             {
139 0 0 0       Net::DRI::Exception::usererr_invalid_parameters('years must be between 1 and 99') unless ($y >= 1 && $y <= 99);
140 0           $v=$y;
141 0           $u='y';
142             } else
143             {
144 0 0 0       Net::DRI::Exception::usererr_invalid_parameters('months must be between 1 and 99') unless ($m >= 1 && $m <= 99);
145 0           $v=$m;
146 0           $u='m';
147             }
148              
149 0           return [$ns.':period',$v,{'unit' => $u}];
150             }
151              
152             sub build_ns
153             {
154 0     0 0   my ($epp,$ns,$domain,$xmlns,$noip)=@_;
155              
156 0           my @d;
157 0           my $asattr=$epp->{hostasattr};
158              
159 0 0         if ($asattr)
160             {
161 0           foreach my $i (1..$ns->count())
162             {
163 0           my ($n,$r4,$r6)=$ns->get_details($i);
164 0           my @h;
165 0           push @h,['domain:hostName',$n];
166 0 0 0       if ((($n=~m/\S+\.${domain}$/i) || (lc($n) eq lc($domain)) || ($asattr==2)) && (!defined($noip) || !$noip))
      0        
      0        
167             {
168 0 0         push @h,map { ['domain:hostAddr',$_,{ip=>'v4'}] } @$r4 if @$r4;
  0            
169 0 0         push @h,map { ['domain:hostAddr',$_,{ip=>'v6'}] } @$r6 if @$r6;
  0            
170             }
171 0           push @d,['domain:hostAttr',@h];
172             }
173             } else
174             {
175 0           @d=map { ['domain:hostObj',$_] } $ns->get_names();
  0            
176             }
177              
178 0 0         $xmlns='domain' unless defined($xmlns);
179 0           return [$xmlns.':ns',@d];
180             }
181              
182             sub parse_ns ## RFC 4931 ยง1.1
183             {
184 0     0 0   my ($po,$node)=@_;
185 0           my $ns=$po->create_local_object('hosts');
186              
187 0           foreach my $el (Net::DRI::Util::xml_list_children($node))
188             {
189 0           my ($name,$n)=@$el;
190 0 0         if ($name eq 'hostObj')
    0          
191             {
192 0           $ns->add($n->textContent());
193             } elsif ($name eq 'hostAttr')
194             {
195 0           my ($hostname,@ip4,@ip6);
196 0           foreach my $sel (Net::DRI::Util::xml_list_children($n))
197             {
198 0           my ($name2,$nn)=@$sel;
199 0 0         if ($name2 eq 'hostName')
    0          
200             {
201 0           $hostname=$nn->textContent();
202             } elsif ($name2 eq 'hostAddr')
203             {
204 0   0       my $ip=$nn->getAttribute('ip') || 'v4';
205 0 0         if ($ip eq 'v6')
206             {
207 0           push @ip6,$nn->textContent();
208             } else
209             {
210 0           push @ip4,$nn->textContent();
211             }
212             }
213             }
214 0           $ns->add($hostname,\@ip4,\@ip6,1);
215             }
216             }
217 0           return $ns;
218             }
219              
220             ## was Core::Domain::build_contact_noregistrant
221             sub build_core_contacts
222             {
223 0     0 0   my ($epp,$cs,$ns)=@_;
224 0           my @d;
225             # All nonstandard contacts go into the extension section
226 0           my %r=map { $_ => 1 } $epp->core_contact_types();
  0            
227 0           foreach my $t (sort(grep { exists($r{$_}) } $cs->types()))
  0            
228             {
229 0           my @o=$cs->get($t);
230 0   0       push @d,map { [ ($ns // 'domain').':contact',$_->srid(),{'type'=>$t}] } @o;
  0            
231             }
232 0           return @d;
233             }
234              
235             sub parse_postalinfo
236             {
237 0     0 0   my ($epp,$pi,$rcd)=@_;
238 0           my $type=$pi->getAttribute('type'); ## int or loc, mandatory in EPP !
239 0 0 0       $type=$epp->{defaulti18ntype} if (!defined($type) && defined($epp->{defaulti18ntype}));
240 0           state $index={'loc' => 0, 'int' => 1};
241 0           my $ti=$index->{$type};
242              
243 0           foreach my $el (Net::DRI::Util::xml_list_children($pi))
244             {
245 0           my ($name,$node)=@$el;
246 0 0         if ($name=~m/^(name|org)$/)
    0          
247             {
248 0           $rcd->{$name}->[$ti]=$node->textContent();
249             } elsif ($name eq 'addr')
250             {
251 0           my @street;
252 0           foreach my $sel (Net::DRI::Util::xml_list_children($node))
253             {
254 0           my ($subname,$subnode)=@$sel;
255 0 0         if ($subname eq 'street')
    0          
256             {
257 0           push @street,$subnode->textContent();
258             } elsif ($subname=~m/^(city|sp|pc|cc)$/)
259             {
260 0           $rcd->{$subname}->[$ti]=$subnode->textContent();
261             }
262             }
263 0           $rcd->{street}->[$ti]=\@street;
264             }
265             }
266 0           return;
267             }
268              
269             sub parse_disclose
270             {
271 0     0 0   my ($disclose)=@_;
272 0           my $flag=Net::DRI::Util::xml_parse_boolean($disclose->getAttribute('flag'));
273 0           my %r;
274 0           foreach my $el (Net::DRI::Util::xml_list_children($disclose))
275             {
276 0           my ($name,$node)=@$el;
277 0 0         if ($name=~m/^(name|org|addr)$/)
278             {
279 0           $r{$1.'_'.$node->getAttribute('type')}=$flag;
280             } else
281             {
282 0           $r{$name}=$flag;
283             }
284             }
285 0           return \%r;
286             }
287              
288             sub build_disclose
289             {
290 0     0 0   my ($d,$ns,@items)=@_;
291 0   0       $ns//='contact';
292 0 0 0       return () unless $d && ref $d eq 'HASH';
293 0           my %v=map { $_ => 1 } values %$d;
  0            
294 0 0         return () unless keys(%v)==1; ## 1 or 0 as values, not both at same time
295 0           my @d;
296              
297 0           state $l1 = [ qw/name org addr/ ];
298 0           foreach my $item (@$l1)
299             {
300 0 0         if (exists $d->{$item})
301             {
302 0           push @d,[$ns.':'.$item,{type=>'int'}],[$ns.':name',{type=>'loc'}];
303             } else
304             {
305 0 0         push @d,[$ns.':'.$item,{type=>'int'}] if exists $d->{$item.'_int'};
306 0 0         push @d,[$ns.':'.$item,{type=>'loc'}] if exists $d->{$item.'_loc'};
307             }
308             }
309 0           state $l2 = [ qw/voice fax email/ ];
310 0           foreach my $item (@$l2, @items)
311             {
312 0 0         push @d,[$ns.':'.$item] if exists $d->{$item};
313             }
314 0           return [$ns.':disclose',@d,{flag=>(keys(%v))[0]}];
315             }
316              
317             sub _do_locint
318             {
319 0     0     my ($rl,$ri,$contact,$ns,$what)=@_;
320 0           my @tmp=$contact->$what();
321 0 0         return unless @tmp;
322 0 0         if ($what eq 'street')
323             {
324 0 0         if (defined($tmp[0])) { foreach (@{$tmp[0]}) { push @$rl,[$ns.':street',$_]; } };
  0            
  0            
  0            
325 0 0         if (defined($tmp[1])) { foreach (@{$tmp[1]}) { push @$ri,[$ns.':street',$_]; } };
  0            
  0            
  0            
326             } else
327             {
328 0 0         if (defined($tmp[0])) { push @$rl,[$ns.':'.$what,$tmp[0]]; }
  0            
329 0 0         if (defined($tmp[1])) { push @$ri,[$ns.':'.$what,$tmp[1]]; }
  0            
330             }
331 0           return;
332             }
333              
334             sub build_postalinfo
335             {
336 0     0 0   my ($contact,$v,$ns)=@_;
337 0   0       $ns//='contact';
338 0           my $hasloc=$contact->has_loc();
339 0           my $hasint=$contact->has_int();
340 0 0 0       if ($hasint && !$hasloc && (($v & 5) == $v))
    0 0        
      0        
      0        
341             {
342 0           $contact->int2loc();
343 0           $hasloc=1;
344             } elsif ($hasloc && !$hasint && (($v & 6) == $v))
345             {
346 0           $contact->loc2int();
347 0           $hasint=1;
348             }
349              
350 0           my (@postl,@posti,@addrl,@addri);
351 0           _do_locint(\@postl,\@posti,$contact,$ns,'name');
352 0           _do_locint(\@postl,\@posti,$contact,$ns,'org');
353 0           _do_locint(\@addrl,\@addri,$contact,$ns,'street');
354 0           _do_locint(\@addrl,\@addri,$contact,$ns,'city');
355 0           _do_locint(\@addrl,\@addri,$contact,$ns,'sp');
356 0           _do_locint(\@addrl,\@addri,$contact,$ns,'pc');
357 0           _do_locint(\@addrl,\@addri,$contact,$ns,'cc');
358 0 0         push @postl,[$ns.':addr',@addrl] if @addrl;
359 0 0         push @posti,[$ns.':addr',@addri] if @addri;
360              
361 0           my @d;
362 0 0 0       push @d,[$ns.':postalInfo',@postl,{type=>'loc'}] if (($v & 5) && $hasloc); ## loc+int OR loc
363 0 0 0       push @d,[$ns.':postalInfo',@posti,{type=>'int'}] if (($v & 6) && $hasint); ## loc+int OR int
364              
365 0           return @d;
366             }
367              
368             ####################################################################################################
369             1;
370              
371             __END__