File Coverage

blib/lib/IO/EPP/RRPProxy.pm
Criterion Covered Total %
statement 12 135 8.8
branch 0 72 0.0
condition 0 31 0.0
subroutine 4 15 26.6
pod 10 10 100.0
total 26 263 9.8


line stmt bran cond sub pod time code
1             package IO::EPP::RRPProxy;
2              
3             =encoding utf8
4              
5             =head1 NAME
6              
7             IO::EPP::RRPProxy
8              
9             =head1 SYNOPSIS
10              
11             use IO::EPP::RRPProxy;
12              
13             # Parameters for IO::Socket::SSL
14             my %sock_params = (
15             PeerHost => 'epp.rrpproxy.net',
16             PeerPort => 700,
17             Timeout => 30,
18             );
19              
20             # Create object, get greeting and call login()
21             my $conn = IO::EPP::RRPProxy->new( {
22             user => 'login',
23             pass => 'xxxxx',
24             sock_params => \%sock_params,
25             test_mode => 0, # real connect
26             } );
27              
28             # Check domain
29             my ( $answ, $code, $msg ) = $conn->check_domains( { domains => [ 'info.name', 'name.info' ] } );
30              
31             # Call logout() and destroy object
32             undef $conn;
33              
34             =head1 DESCRIPTION
35              
36             Work with RRPProxy EPP API
37              
38             Features:
39              
40             =over 3
41              
42             item *
43              
44             has its own epp extension for specifying additional parameters;
45              
46             =item *
47              
48             has additional functions.
49              
50             =back
51              
52             Examples: L, L.
53              
54             =cut
55              
56 1     1   1851 use IO::EPP::Base;
  1         3  
  1         33  
57 1     1   6 use parent qw( IO::EPP::Base );
  1         1  
  1         6  
58              
59 1     1   59 use strict;
  1         2  
  1         15  
60 1     1   4 use warnings;
  1         2  
  1         1477  
61              
62             my $ks_ext = 'xmlns:keysys="http://www.key-systems.net/epp/keysys-1.0"';
63              
64             sub make_request {
65 0     0 1   my ( $action, $params ) = @_;
66              
67 0           my ( $self, $code, $msg, $answ );
68              
69 0 0         unless ( $params->{conn} ) {
70 0   0       $params->{sock_params}{PeerHost} ||= 'epp.rrpproxy.net';
71 0   0       $params->{sock_params}{PeerPort} ||= 700;
72              
73 0           ( $self, $code, $msg ) = __PACKAGE__->new( $params );
74              
75 0 0 0       unless ( $code and $code == 1000 ) {
76 0           goto END_MR;
77             }
78             }
79             else {
80 0           $self = $params->{conn};
81             }
82              
83              
84 0           $self->{critical_error} = '';
85              
86 0 0         if ( $self->can( $action ) ) {
87 0           ( $answ, $code, $msg ) = $self->$action( $params );
88             }
89             else {
90 0           $msg = "undefined command <$action>, request cancelled";
91 0           $code = 0;
92             }
93              
94              
95             END_MR:
96              
97 0 0         $msg .= '; ' . $self->{critical_error} if $self->{critical_error};
98              
99 0           my $full_answ = "code: $code\nmsg: $msg";
100              
101 0 0 0       $answ = {} unless $answ && ref $answ;
102              
103 0           $answ->{code} = $code;
104 0           $answ->{msg} = $msg;
105              
106 0 0         return wantarray ? ( $answ, $full_answ, $self ) : $answ;
107             }
108              
109             =head1 METHODS
110              
111             Further overlap functions where the provider has features
112              
113             =head2 login
114              
115             Ext params for login,
116              
117             INPUT: new password for change
118              
119             =cut
120              
121             sub login {
122 0     0 1   my ( $self, $pw ) = @_;
123              
124 0           my $svcs = '
125             urn:ietf:params:xml:ns:contact-1.0
126             urn:ietf:params:xml:ns:domain-1.0
127             urn:ietf:params:xml:ns:host-1.0';
128              
129 0           my $extension = '
130             http://www.key-systems.net/epp/keysys-1.0
131             http://www.key-systems.net/epp/query-1.0
132             urn:ietf:params:xml:ns:secDNS-1.1
133             urn:ietf:params:xml:ns:rgp-1.0
134             urn:ietf:params:xml:ns:launchphase-1.0
135             urn:ietf:params:xml:ns:launch-1.0
136             urn:ietf:params:xml:ns:idn-1.0
137             urn:ietf:params:xml:ns:fee-0.7';
138              
139 0           return $self->SUPER::login( $pw, $svcs, $extension );
140             }
141              
142             =head2 create_contact
143              
144             Contact id is generated automatically by the reseller
145              
146             =cut
147              
148             sub create_contact {
149 0     0 1   my ( $self, $params ) = @_;
150              
151 0           $params->{id} = 'AUTO';
152              
153 0 0         $params->{company} =~ s/&/&/g if $params->{company};
154 0 0         $params->{addr} =~ s/&/&/g if $params->{addr};
155              
156             =pod
157              
158             For german characters changes html codes to double symbols:
159             ß = ss
160             ä = ae
161             ü = ue
162             ö = oe
163              
164             =cut
165 0           foreach my $f ( 'name', 'company', 'addr', 'city', 'state' ) {
166 0 0         next unless $params->{$f};
167              
168 0           $params->{$f} =~ s/Ä/Ae/g;
169 0           $params->{$f} =~ s/Ö/Oe/g;
170 0           $params->{$f} =~ s/Ü/Ue/g;
171 0           $params->{$f} =~ s/ß/ss/g;
172 0           $params->{$f} =~ s/ä/ae/g;
173 0           $params->{$f} =~ s/ö/oe/g;
174 0           $params->{$f} =~ s/ü/ue/g;
175             }
176              
177             # the extension fields must be arranged in alphabetical order
178              
179 0           my $fields = "\n 1\n";
180              
181             # each contact is registered separately even if they are the same
182             $params->{extension} =
183 0           qq|
184             $fields
185            
186            
187             |;
188              
189 0           return $self->SUPER::create_contact( $params );
190             }
191              
192              
193             =head2 check_claims
194              
195             Get info on Claims Notice
196              
197             For details see L
198              
199             INPUT:
200              
201             key of params:
202             C -- domain name
203              
204             =cut
205              
206             sub check_claims {
207 0     0 1   my ( $self, $params ) = @_;
208              
209 0           $params->{domains} = [ $params->{dname} ];
210              
211             $params->{extension} =
212 0           '
213             claims
214            
215             ';
216              
217 0           return $self->SUPER::check_domains( $params );
218             }
219              
220              
221             # Compile trade, premium and tlds extension
222              
223             sub _keysys_domain_ext {
224 0     0     my ( $params ) = @_;
225              
226 0           foreach my $f ( keys %$params ) {
227 0 0         if ( $f =~ /^x-/ ) {
228 0           $params->{ uc($f) } = delete $params->{$f};
229             }
230             }
231              
232 0 0         unless ( $params->{tld} ) {
233 0           ( $params->{tld} ) = $params->{dname} =~ /\.([0-9A-Za-z\-]+)$/;
234             }
235              
236 0           my $tld = uc $params->{tld};
237              
238 0           my %ext;
239              
240             # for epp need lc
241 0           foreach my $f ( keys %$params ) {
242 0 0 0       if ( $f =~ /^X-$tld-$/ or $f eq 'X-ACCEPT-PREMIUMPRICE' or $f eq 'X-ACCEPT-TRADE' ) {
      0        
243 0           $ext{ lc($f) } = delete $params->{$f};
244             }
245             }
246              
247 0           my $extension = '';
248             # the extension fields must be arranged in alphabetical order
249 0           foreach my $f ( sort keys %ext ) {
250 0           my $f1 = $f;
251 0           $f1 =~ s/^x-//;
252 0           $extension .= " $ext{$f}\n";
253             }
254              
255 0           return $extension;
256             }
257              
258             =head2 create_domain
259              
260             additional keys of params:
261              
262             C -- register a premium domain without specifying the price, but it must be allowed in the panel;
263              
264             C, C -- price for premium domain;
265              
266             C -- currency for price for premium domain;
267              
268             C -- subhash for claims parameters:
269             C, C, C.
270             For details see L;
271              
272             The other parameters are zone-specific and are set as specified in The RRPProxy documentation: C.
273              
274             =cut
275              
276             sub create_domain {
277 0     0 1   my ( $self, $params ) = @_;
278              
279 0           $params->{authinfo} = ''; # need empty
280              
281             # Set as RRPProxy documentation, but not epp extension documentation
282 0 0         $params->{'X-ACCEPT-PREMIUMPRICE'} = 1 if delete $params->{is_premium}; # https://wiki.rrpproxy.net/domains/premium-domains
283 0 0         $params->{'X-FEE-AMOUNT'} = delete $params->{premium_price} if defined $params->{premium_price}; # zero is correct price
284 0 0         $params->{'X-FEE-AMOUNT'} = delete $params->{'fee-fee'} if defined $params->{'fee-fee'};
285 0 0         $params->{'X-FEE-CURRENCY'} = delete $params->{premium_currency} if $params->{premium_currency};
286              
287 0           my $extension = _keysys_domain_ext( $params );
288              
289             # closing special domain extensions
290 0 0         if ( $extension ) {
291 0           $extension =
292             qq|
293             $extension
294            
295            
296             |;
297             }
298              
299              
300 0 0         if ( defined $params->{'X-FEE-AMOUNT'} ) { # https://wiki.rrpproxy.net/domains/premium-domains/x-fee-parameters
301             # price can be zero
302 0           $extension .= qq| \n|;
303              
304 0 0         if ( $params->{'X-FEE-CURRENCY'} ) {
305 0           $extension .= ' ' . $params->{'X-FEE-CURRENCY'} . "\n";
306             }
307              
308 0           $extension .= ' ' . $params->{'X-FEE-AMOUNT'} . "\n \n";
309             }
310              
311              
312 0 0         if ( $params->{claims} ) {
313             $extension .=
314             '
315             claims
316            
317             '. $params->{claims}{noticeID} .'
318             '. $params->{claims}{notAfter} .'
319 0           '.$params->{claims}{acceptedDate}.'
320            
321            
322             ';
323             }
324              
325 0 0         $params->{extension} = $extension if $extension;
326              
327 0           return $self->SUPER::create_domain( $params );
328             }
329              
330              
331             =head2 transfer
332              
333             INPUT
334              
335             For premium domains, you need to pass a special parameter is_premium
336              
337             You can also specify contact id for some tlds: C, C, C, C
338              
339             All other parameters such as L.
340              
341             =cut
342              
343             sub transfer {
344 0     0 1   my ( $self, $params ) = @_;
345              
346 0 0         if ( defined $params->{authinfo} ) {
347 0           $params->{authinfo} =~ s/&/&/g;
348 0           $params->{authinfo} =~ s/
349 0           $params->{authinfo} =~ s/>/>/g;
350             }
351              
352 0           my $extension = '';
353              
354 0 0 0       if ( $params->{is_premium} || $params->{'X-ACCEPT-PREMIUMPRICE'} || $params->{'x-accept-premiumprice'} ) {
      0        
355 0           $extension .= " 1\n";
356             }
357              
358 0 0 0       if ( $params->{reg_id} || $params->{admin_id} ) {
359 0 0         $extension .= " $$params{reg_id}\n" if $params->{reg_id};
360 0 0         $extension .= " $$params{admin_id}\n" if $params->{admin_id};
361 0 0         $extension .= " $$params{tech_id}\n" if $params->{tech_id};
362 0 0         $extension .= " $$params{billing_id}\n" if $params->{billing_id};
363             }
364              
365 0 0         if ( $extension ) {
366             $params->{extension} =
367 0           qq|
368            
369             $extension
370            
371             |;
372             }
373              
374 0           return $self->SUPER::transfer( $params );
375             }
376              
377             =head2 renew_domain
378              
379             For renewal of the premium domain name, you need to pass a parameter C or C
380              
381             =cut
382              
383             sub renew_domain {
384 0     0 1   my ( $self, $params ) = @_;
385              
386 0 0 0       if ( $params->{is_premium} || $params->{'X-ACCEPT-PREMIUMPRICE'} || $params->{'x-accept-premiumprice'} ) {
      0        
387             # https://wiki.rrpproxy.net/domains/premium-domains
388             $params->{extension} =
389 0           qq|
390            
391             1
392            
393            
394             |;
395             }
396              
397 0           return $self->SUPER::renew_domain( $params );
398             }
399              
400              
401             =head2 update_domain
402              
403             C – option for special change of domain owner – paid or requires confirmation;
404              
405             =cut
406              
407             sub update_domain {
408 0     0 1   my ( $self, $params ) = @_;
409              
410 0 0         $params->{'X-ACCEPT-TRADE'} = 1 if delete $params->{trade};
411              
412 0           my $extension = _keysys_domain_ext( $params );
413              
414 0 0         if ( $extension ) {
415             $params->{extension} =
416 0           qq|
417             $extension
418            
419            
420             |;
421             }
422              
423 0           return $self->SUPER::update_domain( $params );
424             }
425              
426              
427             =head2 set_domain_renewal_mode
428              
429             Set renewal mode for domain.
430              
431             INPUT:
432              
433             params with key:
434              
435             C – valid values: C, C, C, C, C
436              
437             For details see L
438              
439             OUTPUT:
440             see L
441              
442             =cut
443              
444             sub set_domain_renewal_mode {
445 0     0 1   my ( $self, $params ) = @_;
446              
447 0           $params->{renewal_mode} = uc $params->{renewal_mode};
448              
449             $params->{extension} =
450 0           qq|
451            
452             $$params{renewal_mode}
453            
454            
455             |;
456              
457 0           return $self->update_domain( $params );
458             }
459              
460              
461             =head2 req_poll_ext
462              
463             keysys extension for the req poll
464              
465             =cut
466              
467             sub req_poll_ext {
468 0     0 1   my ( undef, $ext ) = @_;
469              
470 0           my %info;
471              
472 0 0         if ( $ext =~ /]+>(.+?)<\/keysys:poll>/s ) {
473 0           my $key_ext = $1;
474              
475 0           foreach my $type ( 'data', 'info' ) {
476 0 0         if ( $key_ext =~ /(.+?)<\/keysys:$type>/s ) {
477 0           my $data = $1;
478              
479 0           my @data = $data =~ /<[^<>]+>[^<>]+<\/[^<>]+>/g;
480              
481 0 0         if ( scalar @data ) {
482 0           foreach my $row ( @data ) {
483 0 0         if ( $row =~ /<([^<>]+)>([^<>]+)<\/[^<>]+>/ ) {
484 0           $info{$1} = $2;
485             }
486             }
487             }
488             else {
489 0           $info{$type} = $data;
490             }
491             }
492             }
493             }
494              
495 0           return \%info;
496             }
497              
498              
499             1;
500              
501             __END__