File Coverage

blib/lib/Net/DRI/Protocol/EPP/Extensions/CIRA/IDN.pm
Criterion Covered Total %
statement 15 84 17.8
branch 0 34 0.0
condition 0 3 0.0
subroutine 5 14 35.7
pod 0 8 0.0
total 20 143 13.9


line stmt bran cond sub pod time code
1             ## Domain Registry Interface, CIRA IDN handling (draft-wilcox-cira-idn-eppext-00)
2             ##
3             ## Copyright (c) 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::Extensions::CIRA::IDN;
16              
17 1     1   657 use strict;
  1         1  
  1         22  
18 1     1   3 use warnings;
  1         2  
  1         19  
19 1     1   4 use feature 'state';
  1         1  
  1         49  
20              
21 1     1   3 use Net::DRI::Util;
  1         1  
  1         13  
22 1     1   2 use Net::DRI::Exception;
  1         1  
  1         1576  
23              
24             ####################################################################################################
25              
26             sub register_commands
27             {
28 0     0 0   my ($class,$version)=@_;
29 0           state $ops = { 'domain' => { check => [ \&domain_check_build, undef ],
30             check_multi => [ \&domain_check_build, undef ],
31             info => [ undef, \&domain_info_parse ],
32             create => [ \&domain_create_build, undef ],
33             },
34             'bundle' => { info => [ \&bundle_info_build, \&bundle_info_parse ],
35             },
36             };
37              
38 0           return $ops;
39             }
40              
41             sub setup
42             {
43 0     0 0   my ($class,$po,$version)=@_;
44 0           state $ns={ 'cira-idn' => [ 'urn:ietf:params:xml:ns:cira-idn-1.0','cira-idn-1.0.xsd' ],
45             'cira-idn-bundle' => [ 'urn:ietf:params:xml:ns:cira-idn-bundle-1.0','cira-idn-bundle-1.0.xsd' ],
46             };
47 0           $po->ns($ns);
48 0           return;
49             }
50              
51 0     0 0   sub implements { return 'https://tools.ietf.org/html/draft-wilcox-cira-idn-eppext-00'; }
52              
53             ####################################################################################################
54              
55             sub _validate_repertoire
56             {
57 0     0     my ($rp)=@_;
58             ## This set is called a repertoire throughout the document, as a synonym with idn_table.
59 0 0         return 0 unless Net::DRI::Util::has_key($rp,'idn_table');
60 0 0         Net::DRI::Exception::usererr_invalid_parameters('idn_table must be of type XML schema token with 2 characters') unless Net::DRI::Util::xml_is_token($rp->{idn_table},2,2);
61 0           return 1;
62             }
63              
64             sub domain_check_build
65             {
66 0     0 0   my ($epp,$domain,$rp)=@_;
67 0           my $mes=$epp->message();
68 0 0         return unless _validate_repertoire($rp);
69 0           my $eid=$mes->command_extension_register('cira-idn','ciraIdnCheck');
70 0           $mes->command_extension($eid,['cira-idn:repertoire',$rp->{idn_table}]);
71 0           return;
72             }
73              
74             sub domain_info_parse
75             {
76 0     0 0   my ($po,$otype,$oaction,$oname,$rinfo)=@_;
77 0           my $mes=$po->message();
78 0 0         return unless $mes->is_success();
79              
80 0           my $data=$mes->get_extension('cira-idn','ciraIdnInfo');
81 0 0         return unless defined $data;
82              
83 0           my @v=map { $_->textContent() } Net::DRI::Util::xml_traverse($data,$mes->ns('cira-idn'),qw/domainVariants name/);
  0            
84 0           $rinfo->{domain}->{$oname}->{variants}=\@v;
85 0           return;
86             }
87              
88             sub bundle_info_build
89             {
90 0     0 0   my ($epp,$bundle,$rp)=@_;
91 0           my $mes=$epp->message();
92              
93 0           my @d;
94 0 0         Net::DRI::Exception::usererr_invalid_parameters('bundle name must be of type eppcom:labelType') unless Net::DRI::Util::xml_is_token($bundle,1,255);
95 0           push @d,['cira-idn-bundle:name',$bundle];
96 0 0         if (_validate_repertoire($rp))
97             {
98 0           push @d,['cira-idn-bundle:repertoire',$rp->{idn_table}];
99             }
100              
101 0           $mes->command(['info','cira-idn-bundle:info',sprintf('xmlns:cira-idn-bundle="%s" xsi:schemaLocation="%s %s"',$mes->nsattrs('cira-idn-bundle'))]);
102 0           $mes->command_body(\@d);
103 0           return;
104             }
105              
106             sub bundle_info_parse
107             {
108 0     0 0   my ($po,$otype,$oaction,$oname,$rinfo)=@_;
109 0           my $mes=$po->message();
110 0 0         return unless $mes->is_success();
111              
112 0           my $data=$mes->get_extension('cira-idn-bundle','infData');
113 0 0         return unless defined $data;
114              
115 0           my %r;
116 0           my $cs=$po->create_local_object('contactset');
117 0           foreach my $el (Net::DRI::Util::xml_list_children($data))
118             {
119 0           my ($name,$c)=@$el;
120 0 0 0       if ($name eq 'canonicalDomainName' || $name eq 'roid')
    0          
    0          
    0          
    0          
121             {
122 0           $r{Net::DRI::Util::remcam($name)}=$c->textContent();
123             } elsif ($name eq 'registrant')
124             {
125 0           $cs->set($po->create_local_object('contact')->srid($c->textContent()),'registrant');
126 0           $r{contact}=$cs;
127             } elsif ($name=~m/^(clID|crID|upID)$/)
128             {
129 0           $r{$1}=$c->textContent();
130             } elsif ($name=~m/^(crDate|upDate|trDate)$/)
131             {
132 0           $r{$1}=$po->parse_iso8601($c->textContent());
133             } elsif ($name eq 'bundleDomains')
134             {
135 0           $r{variants}=[ map { $_->textContent() } Net::DRI::Util::xml_traverse($c,$mes->ns('cira-idn'),qw/name/) ];
  0            
136             }
137             }
138              
139 0           foreach my $domain (@{$r{variants}}, $r{canonical_domain_name}) ## $oname is among $r{variants}
  0            
140             {
141 0           $rinfo->{bundle}->{$domain}=\%r;
142             }
143              
144 0           return;
145             }
146              
147             sub domain_create_build
148             {
149 0     0 0   my ($epp,$domain,$rp)=@_;
150 0           my $mes=$epp->message();
151              
152 0 0         return unless _validate_repertoire($rp);
153              
154 0           my @d;
155 0           push @d,['cira-idn:repertoire',$rp->{idn_table}];
156 0 0         if (Net::DRI::Util::has_key($rp,'ulabel')) ## TODO: compute u-label directly from $domain
157             {
158 0 0         Net::DRI::Exception::usererr_invalid_parameters('ulabel must be of type eppcom:labelType') unless Net::DRI::Util::xml_is_token($rp->{ulabel},1,255);
159 0           push @d,['cira-idn:u-label',$rp->{ulabel}];
160             }
161              
162 0           my $eid=$mes->command_extension_register('cira-idn','ciraIdnCreate');
163 0           $mes->command_extension($eid,\@d);
164 0           return;
165             }
166              
167             ####################################################################################################
168             1;
169              
170             __END__