File Coverage

blib/lib/Net/DRI/Protocol/RRP/Core/Domain.pm
Criterion Covered Total %
statement 99 137 72.2
branch 21 58 36.2
condition 7 34 20.5
subroutine 16 21 76.1
pod 0 14 0.0
total 143 264 54.1


line stmt bran cond sub pod time code
1             ## Domain Registry Interface, RRP Domain commands
2             ##
3             ## Copyright (c) 2005,2006,2008,2013 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::RRP::Core::Domain;
16              
17 2     2   1288 use strict;
  2         2  
  2         49  
18 2     2   7 use warnings;
  2         4  
  2         41  
19              
20 2     2   8 use Net::DRI::Data::Hosts;
  2         2  
  2         13  
21 2     2   397 use Net::DRI::Protocol::RRP::Core::Status;
  2         4  
  2         348  
22 2     2   351 use Net::DRI::Protocol::RRP;
  2         2  
  2         21  
23 2     2   48 use Net::DRI::Util;
  2         3  
  2         2785  
24              
25             =pod
26              
27             =head1 NAME
28              
29             Net::DRI::Protocol::RRP::Core::Domain - RRP Domain commands for Net::DRI
30              
31             =head1 DESCRIPTION
32              
33             Please see the README file for details.
34              
35             =head1 SUPPORT
36              
37             For now, support questions should be sent to:
38              
39             Enetdri@dotandco.comE
40              
41             Please also see the SUPPORT file in the distribution.
42              
43             =head1 SEE ALSO
44              
45             Ehttp://www.dotandco.com/services/software/Net-DRI/E
46              
47             =head1 AUTHOR
48              
49             Patrick Mevzek, Enetdri@dotandco.comE
50              
51             =head1 COPYRIGHT
52              
53             Copyright (c) 2005,2006,2008,2013 Patrick Mevzek .
54             All rights reserved.
55              
56             This program is free software; you can redistribute it and/or modify
57             it under the terms of the GNU General Public License as published by
58             the Free Software Foundation; either version 2 of the License, or
59             (at your option) any later version.
60              
61             See the LICENSE file that comes with this distribution for more details.
62              
63             =cut
64              
65              
66             ##########################################################
67              
68             sub register_commands
69             {
70 1     1 0 2 my ($class,$version)=@_;
71 1         10 my %tmp=( create => [ \&add, \&add_parse ],
72             check => [ \&check, \&check_parse ],
73             info => [ \&status, \&status_parse ],
74             delete => [ \&del ],
75             renew => [ \&renew, \&renew_parse ],
76             update => [ \&mod ],
77             transfer_request => [ \&transfer_request ],
78             transfer_answer => [ \&transfer_answer ],
79             );
80              
81 1 50       5 $tmp{transfer_cancel}=[ \&transfer_answer ] if ($version eq "2.0");
82 1         4 return { 'domain' => \%tmp };
83             }
84              
85             sub build_msg
86             {
87 7     7 0 8 my ($msg,$command,$domain)=@_;
88 7 50 33     25 Net::DRI::Exception->die(1,'protocol/RRP',2,"Domain name needed") unless defined($domain) && $domain;
89 7 50       40 Net::DRI::Exception->die(1,'protocol/RRP',10,"Invalid domain name") unless ($domain=~m/^[a-z0-9]([a-z0-9\-]{0,61}[a-z0-9])?\.[a-z0-9]([a-z0-9\-]{0,61}[a-z0-9])?$/i); ## from RRP grammar
90 7 50       24 $msg->command($command) if defined($command);
91 7         43 $msg->entities('EntityName','Domain');
92 7         18 $msg->entities('DomainName',uc $domain);
93 7         7 return;
94             }
95              
96             sub add
97             {
98 1     1 0 2 my ($rrp,$domain,$rd)=@_;
99 1         2 my $mes=$rrp->message();
100 1         5 build_msg($mes,'add',$domain);
101              
102             ## (MAY)
103 1 50       3 if (Net::DRI::Util::has_duration($rd))
104             {
105 1         5 my $period=$rd->{duration}->years();
106 1 50       36 Net::DRI::Exceptions::usererr_invalid_parameters('period must be an integer') unless Net::DRI::Util::isint($period);
107 1         4 $mes->options('Period',$period);
108             }
109             ## (MAY) 1 to 13 nameservers
110 1 50       3 if (Net::DRI::Util::has_ns($rd))
111             {
112 0         0 foreach ($rd->{ns}->get_names(13)) { $mes->entities('NameServer',$_); }
  0         0  
113             }
114 1         3 return;
115             }
116              
117             sub add_parse
118             {
119 1     1 0 1 my ($po,$otype,$oaction,$oname,$rinfo)=@_;
120 1         3 my $mes=$po->message();
121 1 50       6 return unless $mes->is_success();
122              
123             ## Create a new DataTime object
124 1         9 my $d='registration expiration date';
125 1         2 $rinfo->{domain}->{$oname}->{$Net::DRI::Protocol::RRP::DATES{$d}}=$po->{dt_parse}->parse_datetime($mes->entities($d));
126 1         830 $rinfo->{domain}->{$oname}->{status}=Net::DRI::Protocol::RRP::Core::Status->new($mes);
127 1         1 $rinfo->{domain}->{$oname}->{exist}=1;
128 1         2 $rinfo->{domain}->{$oname}->{action}='create';
129 1         3 return;
130             }
131              
132             sub renew_parse
133             {
134 0     0 0 0 my ($po,$otype,$oaction,$oname,$rinfo)=@_;
135 0         0 add_parse($po,$otype,$oaction,$oname,$rinfo);
136 0 0       0 $rinfo->{domain}->{$oname}->{action}='renew' if (exists($rinfo->{domain}->{$oname}->{action}));
137 0         0 return;
138             }
139              
140             sub _basic_command
141             {
142 3     3   4 my ($command,$rrp,$domain)=@_;
143 3         7 my $mes=$rrp->message();
144 3         13 build_msg($mes,$command,$domain);
145 3         7 return;
146             }
147              
148 2     2 0 4 sub check { my (@args)=@_; return _basic_command('check',@args); }
  2         4  
149 1     1 0 2 sub status { my (@args)=@_; return _basic_command('status',@args); }
  1         3  
150 0     0 0 0 sub del { my (@args)=@_; return _basic_command('del',@args); }
  0         0  
151 0     0 0 0 sub transfer_request { my (@args)=@_; return _basic_command('transfer',@args); }
  0         0  
152              
153             sub check_parse
154             {
155 2     2 0 3 my ($po,$otype,$oaction,$oname,$rinfo)=@_;
156 2         5 my $mes=$po->message();
157 2 50       19 return unless $mes->is_success();
158              
159 2 50       18 if ($mes->errcode() == 211) ## domain exists
    0          
160             {
161 2         12 $rinfo->{domain}->{$oname}->{exist}=1;
162             } elsif ($mes->errcode() == 210) ## domain available
163             {
164 0         0 $rinfo->{domain}->{$oname}->{exist}=0;
165             }
166 2         4 $rinfo->{domain}->{$oname}->{action}='check';
167 2         5 return;
168             }
169              
170             sub status_parse
171             {
172 1     1 0 3 my ($po,$otype,$oaction,$oname,$rinfo)=@_;
173 1         2 my $mes=$po->message();
174 1 50       7 return unless $mes->is_success();
175              
176 1         9 $rinfo->{domain}->{$oname}->{exist}=1;
177 1         2 $rinfo->{domain}->{$oname}->{action}='info';
178              
179 1         5 while(my ($k,$v)=each(%Net::DRI::Protocol::RRP::DATES))
180             {
181 4         1690 my $d=$mes->entities($k);
182 4 50       10 next unless $d;
183 4         12 $rinfo->{domain}->{$oname}->{$v}=$po->{dt_parse}->parse_datetime($d);
184             }
185              
186 1         538 while(my ($k,$v)=each(%Net::DRI::Protocol::RRP::IDS))
187             {
188 3         8 my $d=$mes->entities($k);
189 3 50       8 next unless $d;
190 3         11 $rinfo->{domain}->{$oname}->{$v}=$d;
191             }
192            
193 1         4 $rinfo->{domain}->{$oname}->{status}=Net::DRI::Protocol::RRP::Core::Status->new($mes);
194              
195 1         3 my @ns=$mes->entities('nameserver');
196 1         5 $rinfo->{domain}->{$oname}->{ns}=Net::DRI::Data::Hosts->new_set(@ns);
197 1         4 return;
198             }
199              
200             sub transfer_answer
201             {
202 0     0 0 0 my ($rrp,$domain,$rd)=@_;
203 0         0 my $mes=$rrp->message();
204 0         0 build_msg($mes,'transfer',$domain);
205              
206 0 0 0     0 $mes->entities('Approve',(defined($rd) && ref($rd) && exists($rd->{approve}) && $rd->{approve})? 'Yes' : 'No');
207 0         0 return;
208             }
209              
210             sub mod
211             {
212 3     3 0 5 my ($rrp,$domain,$todo)=@_;
213 3         7 my $mes=$rrp->message();
214 3         13 build_msg($mes,'mod',$domain);
215              
216 3 50       7 Net::DRI::Exception::usererr_invalid_parameters($todo.' must be a Net::DRI::Data::Changes object') unless Net::DRI::Util::isa_changes($todo);
217 3 50 33     8 if ((grep { ! /^(?:ns|status)$/ } $todo->types()) ||
  3   33     20  
218 4         21 (grep { ! /^(?:add|del)$/ } $todo->types('ns')) ||
219 0         0 (grep { ! /^(?:add|del)$/ } $todo->types('status'))
220             )
221             {
222 0         0 Net::DRI::Exception->die(0,'protocol/RRP',11,'Only ns/status add/del available for domain');
223             }
224              
225 3         8 my $nsadd=$todo->add('ns');
226 3         6 my $nsdel=$todo->del('ns');
227 3         7 my $statadd=$todo->add('status');
228 3         5 my $statdel=$todo->del('status');
229            
230             ## $nsadd/$nsdel are Net::DRI::Data::Hosts objects
231             ## Up to 13 nameservers only
232 3 100 66     10 if (defined($nsadd) && !$nsadd->is_empty()) { foreach ($nsadd->get_names(13)) { $mes->entities('NameServer',$_) } }
  2         3  
  2         6  
233 3 100 66     12 if (defined($nsdel) && !$nsdel->is_empty()) { foreach ($nsdel->get_names(13)) { $mes->entities('NameServer',$_.'=') } }
  2         4  
  2         7  
234              
235             ## $statadd/$statdel are Net::DRI::Protocol::RRP::Core::Status objects
236 3 50       6 if (defined($statadd)) { foreach ($statadd->list_status()) { $mes->entities('Status',$_) } }
  0         0  
  0         0  
237 3 50       5 if (defined($statdel)) { foreach ($statdel->list_status()) { $mes->entities('Status',$_.'=') } }
  0         0  
  0         0  
238 3         8 return;
239             }
240              
241             sub renew
242             {
243 0     0 0   my ($rrp,$domain,$rd)=@_;
244 0           my ($period,$curexp);
245 0 0 0       if (defined($rd) && (ref($rd) eq 'HASH') && keys(%$rd))
      0        
246             {
247 0           $period=$rd->{duration};
248 0           $curexp=$rd->{current_expiration};
249             }
250 0 0 0       Net::DRI::Exceptions::usererr_insufficient_parameters("current expiration year and period must be both defined or not at all") if (defined($curexp) xor defined($period)); ## both or none should be defined
251 0 0         if (defined($curexp))
252             {
253 0           Net::DRI::Util::check_isa($period,'DateTime::Duration');
254 0           $period=$period->years();
255 0 0         Net::DRI::Exceptions::usererr_invalid_parameters("period must be an integer") unless Net::DRI::Util::isint($period);
256 0 0 0       $curexp=$curexp->year() if (ref($curexp) && $curexp->can('year')); ## for DateTime objects
257 0 0         Net::DRI::Exceptions::usererr_invalid_parameters("current expiration year must be a 4 digits integer") unless $curexp=~m/^\d{4}$/;
258             }
259            
260 0           my $mes=$rrp->message();
261 0           build_msg($mes,'renew',$domain);
262 0 0 0       $mes->options({Period=>$period,CurrentExpirationYear=>$curexp}) if (defined($period) && defined($curexp));
263 0           return;
264             }
265              
266             ####################################################################################################
267             1;