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   1330 use strict;
  4         9  
  4         155  
18 4     4   19 use warnings;
  4         13  
  4         124  
19              
20 4     4   844 use Net::DRI::Exception;
  4         10  
  4         114  
21 4     4   1223 use Net::DRI::Protocol::ResultStatus;
  4         11  
  4         28  
22              
23 4     4   132 use base qw(Class::Accessor::Chained::Fast Net::DRI::Protocol::Message);
  4         8  
  4         2872  
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 378 my $proto=shift;
93 39   33     140 my $class=ref($proto) || $proto;
94              
95 39         82 my $self={errcode => 0};
96 39         120 bless($self,$class);
97              
98 39         37 my $trid=shift;
99              
100 39         135 return $self;
101             }
102              
103 17 100   17 0 41 sub is_success { return (shift->errcode()=~m/^2/)? 1 : 0; }
104              
105             sub result_status
106             {
107 10     10 0 15 my $self=shift;
108 10         25 my $code=$self->errcode();
109 10         58 my $eppcode=_eppcode($code);
110 10         31 return Net::DRI::Protocol::ResultStatus->new('rrp',$code,$eppcode,$self->is_success(),$self->errmsg(),'en');
111             }
112              
113             sub _eppcode
114             {
115 10     10   19 my $code=shift;
116 10 50 33     72 return (defined $code && exists $CODES{$code})? $CODES{$code} : 'COMMAND_FAILED';
117             }
118              
119             sub as_string
120             {
121 38     38 0 171 my $self=shift;
122 38         85 my $cmd=$self->command();
123 38         210 my $ent=$self->entities('EntityName');
124 38         78 my $allopt=$self->options();
125 38         53 my $order=lc($cmd);
126 38 100       93 $order.='_'.lc($ent) if ($ent);
127              
128 38 50       100 Net::DRI::Exception->die(1,'protocol/RRP',5,'Unknown command '.$cmd.', no order found') unless (exists($ORDER{$order}));
129              
130 38         61 my @r=($cmd);
131 38         39 foreach my $o (@{$ORDER{$order}})
  38         77  
132             {
133 104 100       214 if ($o=~m/^-(.+)$/) ## Option
134             {
135 13 100       64 push @r,$o.':'.$allopt->{$1} if exists($allopt->{$1});
136             } else ## Entity
137             {
138 91         130 my @e=$self->entities($o);
139 91 100       189 push @r,map { $o.':'.$_ } @e if @e;
  86         230  
140             }
141             }
142              
143 38         73 push @r,'.'.$EOL; ## end
144 38         214 return join($EOL,@r);
145             }
146              
147             sub parse
148             {
149 12     12 0 34 my ($self,$dc)=@_; ## DataRaw
150 12 50       51 my @todo=map { my $s=$_; $s=~s/\r*\n*\r*$//; $s; } grep { defined() && ! /^\s+$/ } $dc->as_array();
  40         43  
  40         242  
  40         68  
  40         306  
151 12 50       39 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         43 $t=~m/^(\d+)\s+(\S.*\S)\s*$/;
155 12         38 $self->errcode($1);
156 12         95 $self->errmsg($2);
157              
158 12         77 foreach my $l (@todo)
159             {
160 16         32 my ($lh,$rh)=split(/:/,$l,2);
161 16 50       29 if ($lh=~m/^-(.+)$/) ## option
162             {
163 0         0 $self->options($1,$rh);
164             } else ## entity
165             {
166 16         22 $self->entities($lh,$rh);
167             }
168             }
169 12         30 return;
170             }
171              
172             sub entities
173             {
174 220     220 0 1565 my ($self,$k,$v)=@_;
175 220 100       300 if (defined($k))
176             {
177 218 100       266 if (defined($v)) ## key + value => add
178             {
179 73 100       190 $self->{entities}={} unless exists($self->{entities});
180 73 100       152 my @v=(ref($v) eq 'ARRAY')? @$v : ($v);
181 73 100       121 if (exists($self->{entities}->{$k}))
182             {
183 2         2 push @{$self->{entities}->{$k}},@v;
  2         4  
184             } else
185             {
186 71         143 $self->{entities}->{$k}=\@v;
187             }
188 73         165 return $self;
189             } else ## only key given => get value of key
190             {
191 145 100       253 return unless (exists($self->{entities}));
192 142         179 $k=lc($k);
193 142 100       123 foreach my $i ( sort { $a cmp $b } keys %{$self->{entities}} ) { next if lc $i ne $k; $k=$i; last; };
  422         442  
  142         401  
  280         457  
  132         122  
  132         121  
194 142 100       329 return unless (exists($self->{entities}->{$k}));
195 132 100       169 return wantarray()? @{$self->{entities}->{$k}} : join(' ',@{$self->{entities}->{$k}});
  87         210  
  45         146  
196             }
197             } else ## nothing given => get list of keys
198             {
199 2 100       9 return exists $self->{entities} ? ( sort { $a cmp $b } keys %{$self->{entities}} ) : ();
  1         8  
  1         7  
200             }
201             }
202              
203             sub options
204             {
205 48     48 0 68 my ($self,$rh1,$v)=@_;
206 48 100       86 if (defined($rh1)) ## something to add
207             {
208 9 100       24 $self->{options}={} unless exists($self->{options});
209 9 50       18 if (ref($rh1) eq 'HASH')
210             {
211 0         0 $self->{options}={ %{$self->{options}}, %$rh1 };
  0         0  
212             } else
213             {
214 9         17 $self->{options}->{$rh1}=$v;
215             }
216 9         17 return $self;
217             }
218 39 100       101 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;