File Coverage

blib/lib/IO/EPP/DrsUa.pm
Criterion Covered Total %
statement 12 120 10.0
branch 0 44 0.0
condition 0 13 0.0
subroutine 4 15 26.6
pod 10 10 100.0
total 26 202 12.8


line stmt bran cond sub pod time code
1             package IO::EPP::DrsUa;
2              
3             =encoding utf8
4              
5             =head1 NAME
6              
7             IO::EPP::DrsUa
8              
9             =head1 SYNOPSIS
10              
11             use IO::EPP::DrsUa;
12              
13             # Parameters for IO::Socket::SSL
14             my %sock_params = (
15             PeerHost => 'epp.uadns.com',
16             PeerPort => 700,
17             # without certificate
18             Timeout => 30,
19             );
20              
21             # Create object, get greeting and call login()
22             my $conn = IO::EPP::DrsUa->new( {
23             user => 'login',
24             pass => 'xxxx',
25             sock_params => \%sock_params,
26             test_mode => 0, # real connect
27             } );
28              
29             # Check domain
30             my ( $answ, $code, $msg ) = $conn->check_domains( { domains => [ 'qqq.com.ua', 'aaa.biz.ua' ] } );
31              
32             # Call logout() and destroy object
33             undef $conn;
34              
35             =head1 DESCRIPTION
36              
37             Module for work with nic.ua/drs.ua domains
38              
39             Drs.ua is a registry for biz.ua, co.ua, pp.ua and reseller for other .ua tlds
40              
41             drs.ua uses deprecated epp version 0.5 -- it uses hostAttr instead of hostObj
42              
43             Features:
44              
45             =over 4
46              
47             =item *
48              
49             special PP format
50              
51             =item *
52              
53             the contact id must be suffixed on "-cunic"
54              
55             =item *
56              
57             need full name in contact:update
58              
59             =item *
60              
61             to change the email address, you need to update the contact, not change the contact id
62              
63             =item *
64              
65             additional extensions with login should be passed as objURI, not extURI
66              
67             =item *
68              
69             contacts have only type loc
70              
71             =item *
72              
73             no commands host:check, host:create, host:update (consequence of hostAttr)
74              
75             =item *
76              
77             cannot use punycode in the email to the left of @
78              
79             =item *
80              
81             in contacts for an individual, the company field must be empty
82              
83             =item *
84              
85             domains in the zone pp.ua you can not delete, you can only not confirm the sms about registration or renewal so that they themselves are deleted
86              
87             =item *
88              
89             the disclose flag only works for biz.ua, co.ua
90              
91             For pp.ua you can't hide contacts
92              
93             In other tlds Privacy Protection must be performed on the client side
94              
95             =item *
96              
97             epp poll sends only the transaction number and also the result in the form of ok or fail, without the domain name or contact id
98              
99             =back
100              
101             Documentation:
102             L,
103             L
104              
105             =cut
106              
107 1     1   2766 use IO::EPP::Base;
  1         3  
  1         58  
108 1     1   7 use parent qw( IO::EPP::Base );
  1         2  
  1         7  
109              
110 1     1   66 use strict;
  1         2  
  1         18  
111 1     1   5 use warnings;
  1         1  
  1         1604  
112              
113              
114             sub make_request {
115 0     0 1   my ( $action, $params ) = @_;
116              
117 0           my ( $self, $code, $msg, $answ );
118              
119 0 0         unless ( $params->{conn} ) {
120 0   0       $params->{sock_params}{PeerHost} ||= 'epp.uadns.com';
121 0   0       $params->{sock_params}{PeerPort} ||= 700;
122              
123 0           ( $self, $code, $msg ) = __PACKAGE__->new( $params );
124              
125 0 0 0       unless ( $code and $code == 1000 ) {
126 0           goto END_MR;
127             }
128             }
129             else {
130 0           $self = $params->{conn};
131             }
132              
133              
134 0           $self->{critical_error} = '';
135              
136 0 0         if ( $self->can( $action ) ) {
137 0           ( $answ, $code, $msg ) = $self->$action( $params );
138             }
139             else {
140 0           $msg = "undefined command <$action>, request cancelled";
141 0           $code = 0;
142             }
143              
144              
145             END_MR:
146              
147 0 0         $msg .= '; ' . $self->{critical_error} if $self->{critical_error};
148              
149 0           my $full_answ = "code: $code\nmsg: $msg";
150              
151 0 0 0       $answ = {} unless $answ && ref $answ;
152              
153 0           $answ->{code} = $code;
154 0           $answ->{msg} = $msg;
155              
156 0 0         return wantarray ? ( $answ, $full_answ, $self ) : $answ;
157             }
158              
159             =head1 METHODS
160              
161             Further overlap functions where the provider has features
162              
163             =cut
164              
165             sub login {
166 0     0 1   my ( $self, $pw ) = @_;
167              
168             # wihout urn:ietf:params:xml:ns:host
169 0           my $svcs = '
170             urn:ietf:params:xml:ns:contact-1.0
171             urn:ietf:params:xml:ns:domain-1.0';
172              
173 0           my $extension = '
174             http://drs.ua/epp/drs-1.0'; # objURI !!! not extURI !!!
175              
176 0           return $self->SUPER::login( $pw, $svcs, $extension );
177             }
178              
179              
180             sub _prepare_contact {
181 0     0     my ( $params ) = @_;
182              
183             # int only: code: 2400, msg: Only 'loc' type of postal info is supported
184             # int + loc: code: 2400, msg: Multiple postal info not supported
185 0 0         unless ( $$params{'loc'} ) {
186 0           foreach my $f ( 'name','first_name','last_name','company','addr','city','state','postcode','country_code' ) {
187 0 0         $$params{'loc'}{$f} = delete $$params{$f} if defined $$params{$f};
188             }
189             }
190             }
191              
192             =head1 create_contact
193              
194             It has many features, see the description of the module above
195              
196             =cut
197              
198             sub create_contact {
199 0     0 1   my ( $self, $params ) = @_;
200              
201 0           _prepare_contact( $params );
202              
203 0 0         my $visible = $$params{pp_flag} ? 0 : 1;
204              
205             # This format is feature drs, but for biz.ua, co.ua only
206 0           $params->{pp_ext} = '
207            
208            
209            
210            
211            
212            
213            
214             ';
215              
216 0           return $self->SUPER::create_contact( $params );
217             }
218              
219             =head1 update_contact
220              
221             It has many features, see the description of the module above
222              
223             =cut
224              
225             sub update_contact {
226 0     0 1   my ( $self, $params ) = @_;
227              
228 0           _prepare_contact( $params );
229              
230 0           $params->{chg}{need_name} = 1;
231              
232 0 0         my $visible = $$params{pp_flag} ? 0 : 1;
233              
234 0           $params->{pp_ext} = '
235            
236            
237            
238            
239            
240            
241            
242             ';
243              
244 0           return $self->SUPER::update_contact( $params );
245             }
246              
247              
248             sub create_domain_nss {
249 0     0 1   my ( $self, $params ) = @_;
250              
251 0           my $nss = '';
252              
253             # Old EPP version, sbut it was resolved in https://tools.ietf.org/html/rfc3731
254 0           foreach my $ns ( @{$params->{nss}} ) {
  0            
255 0           $nss .= " \n $ns\n \n";
256             }
257              
258 0 0         $nss = "\n \n$nss " if $nss;
259              
260 0           return $nss;
261             }
262              
263              
264             sub create_domain {
265 0     0 1   my ( $self, $params ) = @_;
266              
267 0   0       $params->{authinfo} ||= IO::EPP::Base::gen_pw( 16 );
268              
269 0           return $self->SUPER::create_domain( $params );
270             }
271              
272              
273             sub update_domain_add_nss {
274 0     0 1   my ( $self, $params ) = @_;
275              
276 0           my $add = " \n";
277              
278             # Old EPP version, see in https://tools.ietf.org/html/rfc3731
279 0           foreach my $ns ( @{$$params{add}{nss}} ) {
  0            
280 0           $add .= " \n $$ns{ns}\n";
281 0 0         if ( $ns->{ips} ) {
282 0           foreach my $ip ( @{$ns->{ips}} ) {
  0            
283 0 0         if ( $ip =~ /^\d+\.\d+\.\d+\.\d+$/ ) {
284 0           $add .= " $ip\n";
285             }
286             else {
287 0           $add .= " $ip\n";
288             }
289             }
290             }
291              
292 0           $add .= " \n";
293             }
294              
295 0           $add .= " \n";
296              
297 0           return $add;
298             }
299              
300              
301             sub update_domain_rem_nss {
302 0     0 1   my ( $self, $params ) = @_;
303              
304 0           my $rem = " \n";
305              
306             # Old EPP version, see in https://tools.ietf.org/html/rfc3731
307 0           foreach my $ns ( @{$$params{rem}{nss}} ) {
  0            
308 0           $rem .= " \n $$ns{ns}\n";
309              
310 0 0         if ( $ns->{ips} ) {
311 0           foreach my $ip ( @{$ns->{ips}} ) {
  0            
312 0 0         if ( $ip =~ /^\d+\.\d+\.\d+\.\d+$/ ) {
313 0           $rem .= " $ip\n";
314             }
315             else {
316 0           $rem .= " $ip\n";
317             }
318             }
319             }
320              
321 0           $rem .= " \n";
322             }
323              
324 0           $rem .= " \n";
325              
326 0           return $rem;
327             }
328              
329              
330             sub update_domain {
331 0     0 1   my ( $self, $params ) = @_;
332              
333 0           $params->{nss_as_attr} = 1;
334              
335 0           return $self->SUPER::update_domain( $params );
336             }
337              
338             =head1 req_poll
339              
340             It has many features, see the description of the module above
341              
342             =cut
343              
344             sub req_poll_rdata {
345 0     0 1   my ( $self, $rdata, undef ) = @_;
346              
347 0           my %info;
348              
349 0 0         if ( $rdata =~ /^
    0          
    0          
350             # TRANSFER_PENDING, TRANSFER_CLIENT_APPROVED, TRANSFER_SERVER_APPROVED
351 0           $info{transfer} = {};
352 0           ( $info{transfer}{dname} ) = $rdata =~ /([^<>]+)<\/domain:name>/;
353 0           ( $info{transfer}{status} ) = $rdata =~ /([^<>]+)<\/domain:trStatus>/;
354              
355 0           my %id = %IO::EPP::Base::id;
356 0           foreach my $k ( keys %id ) {
357 0 0         if ( $rdata =~ /([^<>]+)<\/domain:$k>/ ) {
358 0           $info{transfer}{$id{$k}} = $1;
359             }
360             }
361             #( $info{transfer}{from} ) = $rdata =~ /([^<>]+)<\/domain:acID>/;
362             #( $info{transfer}{to} ) = $rdata =~ /([^<>]+)<\/domain:reID>/;
363 0           my %dt = %IO::EPP::Base::dt;
364 0           foreach my $k ( keys %dt ) {
365 0 0         if ( $rdata =~ /([^<>]+)<\/domain:$k>/ ) {
366 0           $info{transfer}{$dt{$k}} = IO::EPP::Base::cldate( $1 );
367             }
368             }
369             }
370             elsif ( $rdata =~ /^
371             # Pending action completed with error.
372             # Pending action completed successfully.
373 0           $info{upd_del} = {};
374 0           ( $info{upd_del}{result}, $info{upd_del}{dname} ) = $rdata =~ /([^<>]+)<\/domain:name>/;
375              
376 0 0         if ( $rdata =~ /(.+)<\/domain:paTRID>/ ) {
377 0           my $trids = $1;
378 0           ( $info{upd_del}{cltrid} ) = $trids =~ /([^<>]+)<\/clTRID>/;
379 0           ( $info{upd_del}{svtrid} ) = $trids =~ /([^<>]+)<\/svTRID>/;
380             }
381              
382 0 0         if ( $rdata =~ /([^<>]+)<\/domain:paDate>/ ) {
383 0           $info{upd_del}{date} = IO::EPP::Base::cldate( $1 );
384             }
385             }
386             elsif ( $rdata =~ /^
387             # drs feature
388 0           $info{notify} = {};
389 0           ( $info{notify}{type} ) = $rdata =~ /([^<>]+)<\/drs:type>/; # command
390 0           ( $info{notify}{object} ) = $rdata =~ /([^<>]+)<\/drs:object>/; # domain
391 0           ( $info{notify}{message} ) = $rdata =~ /([^<>]+)<\/drs:message>/; #
392             }
393             else {
394 0           return ( 0, 'New DrsUa message type!' );
395             }
396              
397 0           return ( \%info, '' );
398             }
399              
400             1;
401              
402              
403             __END__