File Coverage

blib/lib/Net/DRI/Protocol/RRP/Message.pm
Criterion Covered Total %
statement 93 96 96.8
branch 42 48 87.5
condition 2 6 33.3
subroutine 13 13 100.0
pod 1 7 14.2
total 151 170 88.8


line stmt bran cond sub pod time code
1             ## Domain Registry Interface, RRP Message
2             ##
3             ## Copyright (c) 2005-2008,2010,2013-2014 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::Message;
16              
17 4     4   967 use strict;
  4         5  
  4         100  
18 4     4   13 use warnings;
  4         3  
  4         78  
19              
20 4     4   596 use Net::DRI::Exception;
  4         6  
  4         74  
21 4     4   737 use Net::DRI::Protocol::ResultStatus;
  4         5  
  4         20  
22              
23 4     4   109 use base qw(Class::Accessor::Chained::Fast Net::DRI::Protocol::Message);
  4         4  
  4         2157  
24             __PACKAGE__->mk_accessors(qw(version errcode errmsg command));
25              
26             =pod
27              
28             =head1 NAME
29              
30             Net::DRI::Protocol::RRP::Message - RRP Message for Net::DRI
31              
32             =head1 DESCRIPTION
33              
34             Please see the README file for details.
35              
36             =head1 SUPPORT
37              
38             For now, support questions should be sent to:
39              
40             Enetdri@dotandco.comE
41              
42             Please also see the SUPPORT file in the distribution.
43              
44             =head1 SEE ALSO
45              
46             Ehttp://www.dotandco.com/services/software/Net-DRI/E
47              
48             =head1 AUTHOR
49              
50             Patrick Mevzek, Enetdri@dotandco.comE
51              
52             =head1 COPYRIGHT
53              
54             Copyright (c) 2005-2008,2010,2013-2014 Patrick Mevzek .
55             All rights reserved.
56              
57             This program is free software; you can redistribute it and/or modify
58             it under the terms of the GNU General Public License as published by
59             the Free Software Foundation; either version 2 of the License, or
60             (at your option) any later version.
61              
62             See the LICENSE file that comes with this distribution for more details.
63              
64             =cut
65              
66             ####################################################################################################
67              
68             our $EOL="\r\n"; ## as mandated by RFC 2832
69              
70             our %CODES; ## defined at bottom
71              
72             our %ORDER=('add_domain' => ['EntityName','DomainName','-Period','NameServer'],
73             'add_nameserver' => ['EntityName','NameServer','IPAddress'],
74             'check_domain' => ['EntityName','DomainName'],
75             'check_nameserver' => ['EntityName','NameServer'],
76             'del_domain' => ['EntityName','DomainName'],
77             'del_nameserver' => ['EntityName','NameServer'],
78             'describe' => ['-Target'],
79             'mod_domain' => ['EntityName','DomainName','NameServer','Status'],
80             'mod_nameserver' => ['EntityName','NameServer','NewNameServer','IPAddress'],
81             'quit' => [],
82             'renew_domain' => ['EntityName','DomainName','-Period','-CurrentExpirationYear'],
83             'session' => ['-Id','-Password','-NewPassword'],
84             'status_domain' => ['EntityName','DomainName'],
85             'status_nameserver' => ['EntityName','NameServer'],
86             'transfer_domain' => ['-Approve','EntityName','DomainName'],
87             );
88              
89              
90             sub new
91             {
92 39     39 1 595 my $proto=shift;
93 39   33     121 my $class=ref($proto) || $proto;
94              
95 39         66 my $self={errcode => 0};
96 39         45 bless($self,$class);
97              
98 39         37 my $trid=shift;
99              
100 39         96 return $self;
101             }
102              
103 17 100   17 0 31 sub is_success { return (shift->errcode()=~m/^2/)? 1 : 0; }
104              
105             sub result_status
106             {
107 10     10 0 9 my $self=shift;
108 10         17 my $code=$self->errcode();
109 10         49 my $eppcode=_eppcode($code);
110 10         17 return Net::DRI::Protocol::ResultStatus->new('rrp',$code,$eppcode,$self->is_success(),$self->errmsg(),'en');
111             }
112              
113             sub _eppcode
114             {
115 10     10   9 my $code=shift;
116 10 50 33     40 return (defined $code && exists $CODES{$code})? $CODES{$code} : 'COMMAND_FAILED';
117             }
118              
119             sub as_string
120             {
121 38     38 0 135 my $self=shift;
122 38         65 my $cmd=$self->command();
123 38         164 my $ent=$self->entities('EntityName');
124 38         56 my $allopt=$self->options();
125 38         41 my $order=lc($cmd);
126 38 100       80 $order.='_'.lc($ent) if ($ent);
127              
128 38 50       65 Net::DRI::Exception->die(1,'protocol/RRP',5,'Unknown command '.$cmd.', no order found') unless (exists($ORDER{$order}));
129              
130 38         45 my @r=($cmd);
131 38         29 foreach my $o (@{$ORDER{$order}})
  38         62  
132             {
133 104 100       177 if ($o=~m/^-(.+)$/) ## Option
134             {
135 13 100       51 push @r,$o.':'.$allopt->{$1} if exists($allopt->{$1});
136             } else ## Entity
137             {
138 91         118 my @e=$self->entities($o);
139 91 100       170 push @r,map { $o.':'.$_ } @e if @e;
  86         217  
140             }
141             }
142              
143 38         58 push @r,'.'.$EOL; ## end
144 38         180 return join($EOL,@r);
145             }
146              
147             sub parse
148             {
149 12     12 0 28 my ($self,$dc)=@_; ## DataRaw
150 12 50       28 my @todo=map { my $s=$_; $s=~s/\r*\n*\r*$//; $s; } grep { defined() && ! /^\s+$/ } $dc->as_array();
  40         36  
  40         296  
  40         63  
  40         268  
151 12 50       32 Net::DRI::Exception->die(0,'protocol/RRP',1,'Unsuccessfull parse (last line not a lonely dot ') unless (pop(@todo) eq '.');
152              
153 12         16 my $t=shift(@todo);
154 12         34 $t=~m/^(\d+)\s+(\S.*\S)\s*$/;
155 12         31 $self->errcode($1);
156 12         84 $self->errmsg($2);
157              
158 12         64 foreach my $l (@todo)
159             {
160 16         31 my ($lh,$rh)=split(/:/,$l,2);
161 16 50       33 if ($lh=~m/^-(.+)$/) ## option
162             {
163 0         0 $self->options($1,$rh);
164             } else ## entity
165             {
166 16         21 $self->entities($lh,$rh);
167             }
168             }
169 12         24 return;
170             }
171              
172             sub entities
173             {
174 220     220 0 1284 my ($self,$k,$v)=@_;
175 220 100       282 if (defined($k))
176             {
177 218 100       223 if (defined($v)) ## key + value => add
178             {
179 73 100       189 $self->{entities}={} unless exists($self->{entities});
180 73 100       137 my @v=(ref($v) eq 'ARRAY')? @$v : ($v);
181 73 100       94 if (exists($self->{entities}->{$k}))
182             {
183 2         3 push @{$self->{entities}->{$k}},@v;
  2         4  
184             } else
185             {
186 71         102 $self->{entities}->{$k}=\@v;
187             }
188 73         146 return $self;
189             } else ## only key given => get value of key
190             {
191 145 100       217 return unless (exists($self->{entities}));
192 142         159 $k=lc($k);
193 142 100       107 foreach my $i ( sort { $a cmp $b } keys %{$self->{entities}} ) { next if lc $i ne $k; $k=$i; last; };
  407         413  
  142         359  
  280         442  
  132         115  
  132         112  
194 142 100       249 return unless (exists($self->{entities}->{$k}));
195 132 100       148 return wantarray()? @{$self->{entities}->{$k}} : join(' ',@{$self->{entities}->{$k}});
  87         173  
  45         128  
196             }
197             } else ## nothing given => get list of keys
198             {
199 2 100       7 return exists $self->{entities} ? ( sort { $a cmp $b } keys %{$self->{entities}} ) : ();
  1         6  
  1         5  
200             }
201             }
202              
203             sub options
204             {
205 48     48 0 59 my ($self,$rh1,$v)=@_;
206 48 100       71 if (defined($rh1)) ## something to add
207             {
208 9 100       19 $self->{options}={} unless exists($self->{options});
209 9 50       12 if (ref($rh1) eq 'HASH')
210             {
211 0         0 $self->{options}={ %{$self->{options}}, %$rh1 };
  0         0  
212             } else
213             {
214 9         14 $self->{options}->{$rh1}=$v;
215             }
216 9         21 return $self;
217             }
218 39 100       73 return exists($self->{options})? $self->{options} : {};
219             }
220              
221             ####################################################################################################
222              
223             %CODES=(
224             200 => 1000, # Command completed successfully
225             210 => 2303, # Domain name available => Object does not exist
226             211 => 2302, # Domain name not available => Object exists
227             212 => 2303, # Name server available => Object does not exist
228             213 => 2302, # Name server not available => Object exists
229             220 => 1500, # Command completed successfully. Server closing connection
230             420 => 2500, # Command failed due to server error. Server closing connection
231             421 => 2400, # Command failed due to server error. Client should try again
232             500 => 2000, # Invalid command name => Unknown command
233             501 => 2102, # Invalid command option => Unimplemented option
234             502 => 2005, # Invalid entity value => Parameter value syntax error
235             503 => 2005, # Invalid attribute name => Parameter value syntax error
236             504 => 2003, # Missing required attribute => Required parameter missing
237             505 => 2005, # Invalid attribute value syntax => Parameter value syntax error
238             506 => 2004, # Invalid option value => Parameter value range error
239             507 => 2001, # Invalid command format => Command syntax error
240             508 => 2003, # Missing required entity => Required parameter missing
241             509 => 2003, # Missing command option => Required parameter missing
242             510 => 2306, # Invalid encoding => Parameter value policy error (RRP v2.0)
243             520 => 2500, # Server closing connection. Client should try opening new connection => Command failed; server closing connection
244             521 => 2502, # Too many sessions open. Server closing connection => Session limit exceeded; server closing connection
245             530 => 2200, # Authentication failed => Authentication error
246             531 => 2201, # Authorization failed => Authorization error
247             532 => 2305, # Domain names linked with name server => Object association prohibits operation
248             533 => 2305, # Domain name has active name servers => Object association prohibits operation
249             534 => 2301, # Domain name has not been flagged for transfer => Object not pending transfer
250             535 => 2306, # Restricted IP address => Parameter value policy error
251             536 => 2300, # Domain already flagged for transfer => Object pending transfer
252             540 => 2308, # Attribute value is not unique => Data management policy violation
253             541 => 2005, # Invalid attribute value => Parameter value syntax error
254             542 => 2306, # Invalid old value for an attribute => Parameter value policy error
255             543 => 2308, # Final or implicit attribute cannot be updated => Data management policy violation
256             544 => 2304, # Entity on hold => Object status prohibits operation
257             545 => 2308, # Entity reference not found => Data management policy violation
258             546 => 2104, # Credit limit exceeded => Billing failure
259             547 => 2002, # Invalid command sequence => Command use error
260             548 => 2105, # Domain is not up for renewal => Object is not eligible for renewal
261             549 => 2400, # Command failed
262             550 => 2308, # Parent domain not registered => Data management policy violation
263             551 => 2308, # Parent domain status does not allow for operation => Data management policy violation
264             552 => 2304, # Domain status does not allow for operation => Object status prohibits operation
265             553 => 2300, # Operation not allowed. Domain pending transfer => Object pending transfer
266             554 => 2302, # Domain already registered => Object exists
267             555 => 2105, # Domain already renewed => Object is not eligible for renewal
268             556 => 2308, # Maximum registration period exceeded => Data management policy violation
269             557 => 2304, # Name server locked => Object status prohibits operation (RRP v2.0)
270             );
271              
272             ########################################################################
273             1;