File Coverage

blib/lib/Net/DRI/Protocol/ResultStatus.pm
Criterion Covered Total %
statement 78 182 42.8
branch 31 96 32.2
condition 21 50 42.0
subroutine 19 31 61.2
pod 11 20 55.0
total 160 379 42.2


line stmt bran cond sub pod time code
1             ## Domain Registry Interface, Encapsulating result status, standardized on EPP codes
2             ##
3             ## Copyright (c) 2005,2006,2008-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::ResultStatus;
16              
17 81     81   650 use strict;
  81         71  
  81         1785  
18 81     81   220 use warnings;
  81         65  
  81         1656  
19              
20 81     81   220 use base qw(Class::Accessor::Chained::Fast);
  81         77  
  81         7310  
21             __PACKAGE__->mk_ro_accessors(qw(native_code code message lang next count));
22              
23 81     81   14790 use Net::DRI::Exception;
  81         79  
  81         1146  
24 81     81   1704 use Net::DRI::Util;
  81         77  
  81         118864  
25              
26             =pod
27              
28             =head1 NAME
29              
30             Net::DRI::Protocol::ResultStatus - Encapsulate Details of an Operation Result (with Standardization on EPP) for Net::DRI
31              
32             =head1 DESCRIPTION
33              
34             An object of this class represents all details of an operation result as given back from the registry,
35             with standardization on EPP as much as possible, for error codes and list of fields available.
36              
37             One object may contain one or more operation results. The object is in fact a list, starting with the
38             chronologically first/top operation result, and then using the C call progressing toward other
39             operation results, if available (each call to next gives an object of this class). The last operation result
40             can be retrieved with C.
41              
42             When an operation is done, data retrieved from the registry is also stored inside the ResultStatus object
43             (besides being available through C<< $dri->get_info() >>). It can be queried using the C and
44             C methods as explained below. The data is stored as a ref hash with 3 levels:
45             the first keys have as values a reference to another hash where keys are again associated with values
46             being a reference to another hash where the content (keys and values) depends on the registry, the operation
47             attempted, and the result.
48              
49             Some data will always be there: a "session" first key, with a "exchange" subkey, will have a reference to
50             an hash with the following keys:
51              
52             =over
53              
54             =item duration_seconds
55              
56             the duration of the exchange with registry, in a floating point number of seconds
57              
58             =item raw_command
59              
60             the message sent to the registry, as string
61              
62             =item raw_reply
63              
64             the message received from the registry, as string
65              
66             =item result_from_cache
67              
68             either 0 or 1 if these results were retrieved from L Cache object or not
69              
70             =item object_action
71              
72             name of the action that has been done to achieve these results (ex: "info")
73              
74             =item object_name
75              
76             name (or ID) of the object on which the action has been performed (not necessarily always defined)
77              
78             =item object_type
79              
80             type of object on which this operation has been done (ex: "domain")
81              
82             =item registry, profile, transport, protocol
83              
84             registry name, profile name, transport name+version, protocol name+version used for this exchange
85              
86             =item trid
87              
88             transaction ID of this exchange
89              
90             =back
91              
92             =head1 METHODS
93              
94             =head2 is_success()
95              
96             returns 1 if the operation was a success
97              
98             =head2 code()
99              
100             returns the EPP code corresponding to the native code (which depends on the registry)
101             for this operation (see RFC for full list and source of this file for local extensions)
102              
103             =head2 native_code()
104              
105             gives the true status code we got back from registry (this breaks the encapsulation provided by Net::DRI, you should not use it if possible)
106              
107             =head2 message()
108              
109             gives the message attached to the the status code we got back from registry
110              
111             =head2 lang()
112              
113             gives the language in which the message above is written
114              
115             =head2 get_extended_results()
116              
117             gives back an array with additionnal result information from registry, especially in case of errors. If no data, an empty array is returned.
118              
119             This method was previously called info(), before C version 0.92_01
120              
121             =head2 get_data()
122              
123             See explanation of data stored in L. Can be called with one or three parameters and always returns a single value (or undef if failure).
124              
125             With three parameters, it returns the value associated to the three keys/subkeys passed. Example: C will return
126             0 or 1 depending if the domain exists or not, after a domain check or domain info operation.
127              
128             With only one parameter, it will verify there is only one branch (besides session/exchange and message/info), and if so returns the data associated
129             to the parameter passed used as the third key. Otherwise will return undef.
130              
131             Please note that the input API is I the same as the one used for C<$dri->get_info()>.
132              
133             You should not try to modify the data returned in any way, but just read it.
134              
135             =head2 get_data_collection()
136              
137             See explanation of data stored in L. Can be called with either zero, one or two parameters and may return a list or a single value
138             depending on calling context (and respectively an empty list or undef in case of failure).
139              
140             With no parameter, it returns the whole data as reference to an hash with 2 levels beneath as explained in L in scalar context, or
141             the list of keys of this hash in list context.
142              
143             With one parameter, it returns the hash referenced by the key given as argument at first level in scalar context,
144             or the list of keys of this hash in list context.
145              
146             With two parameters, it walks down two level of the hash using the two parameters as key and subkey and returns the bottom hash referenced
147             in scalar context, or the list of keys of this hash in list context.
148              
149             Please note that in all cases you are given references to the data itself, not copies. You should not try to modify it in any way, but just read it.
150              
151             =head2 as_string()
152              
153             returns a string with all details, with the extended_results part if passed a true value
154              
155             =head2 print()
156              
157             same as CORE::print($rs->as_string(0)) or CORE::print($rs->as_string(1)) if passed a true value
158              
159             =head2 trid()
160              
161             in scalar context, gives the transaction id (our transaction id, that is the client part in EPP) which has generated this result,
162             in array context, gives the transaction id followed by other ids given by registry (example in EPP: server transaction id)
163              
164             =head2 is_pending()
165              
166             returns 1 if the operation was flagged as pending by registry (asynchronous handling)
167              
168             =head2 is_closing()
169              
170             returns 1 if the operation made the registry close the connection (should not happen often)
171              
172             =head2 is(NAME)
173              
174             if you really need to test some other codes (this should not happen often), you can using symbolic names
175             defined inside this module (see source).
176             Going that way makes sure you are not hardcoding numbers in your application, and you do not need
177             to import variables from this module to your application.
178              
179             =head1 SUPPORT
180              
181             For now, support questions should be sent to:
182              
183             Enetdri@dotandco.comE
184              
185             Please also see the SUPPORT file in the distribution.
186              
187             =head1 SEE ALSO
188              
189             http://www.dotandco.com/services/software/Net-DRI/
190              
191             =head1 AUTHOR
192              
193             Patrick Mevzek, Enetdri@dotandco.comE
194              
195             =head1 COPYRIGHT
196              
197             Copyright (c) 2005,2006,2008-2014 Patrick Mevzek .
198             All rights reserved.
199              
200             This program is free software; you can redistribute it and/or modify
201             it under the terms of the GNU General Public License as published by
202             the Free Software Foundation; either version 2 of the License, or
203             (at your option) any later version.
204              
205             See the LICENSE file that comes with this distribution for more details.
206              
207             =cut
208              
209             ####################################################################################################
210              
211             our %EPP_CODES=(
212             COMMAND_SUCCESSFUL => 1000,
213             COMMAND_SUCCESSFUL_PENDING => 1001, ## needed for async registries when action done correctly on our side
214             COMMAND_SUCCESSFUL_QUEUE_EMPTY => 1300,
215             COMMAND_SUCCESSFUL_QUEUE_ACK => 1301,
216             COMMAND_SUCCESSFUL_END => 1500, ## after logout
217              
218             UNKNOWN_COMMAND => 2000,
219             COMMAND_SYNTAX_ERROR => 2001,
220             COMMAND_USE_ERROR => 2002,
221             REQUIRED_PARAMETER_MISSING => 2003,
222             PARAMETER_VALUE_RANGE_ERROR => 2004,
223             PARAMETER_VALUE_SYNTAX_ERROR => 2005,
224             UNIMPLEMENTED_PROTOCOL_VERSION => 2100,
225             UNIMPLEMENTED_COMMAND => 2101,
226             UNIMPLEMENTED_OPTION => 2102,
227             UNIMPLEMENTED_EXTENSION => 2103,
228             BILLING_FAILURE => 2104,
229             OBJECT_NOT_ELIGIBLE_FOR_RENEWAL => 2105,
230             OBJECT_NOT_ELIGIBLE_FOR_TRANSFER => 2106,
231             AUTHENTICATION_ERROR => 2200,
232             AUTHORIZATION_ERROR => 2201,
233             INVALID_AUTHORIZATION_INFO => 2202,
234             OBJECT_PENDING_TRANSFER => 2300,
235             OBJECT_NOT_PENDING_TRANSFER => 2301,
236             OBJECT_EXISTS => 2302,
237             OBJECT_DOES_NOT_EXIST => 2303,
238             OBJECT_STATUS_PROHIBITS_OPERATION => 2304,
239             OBJECT_ASSOCIATION_PROHIBITS_OPERATION => 2305,
240             PARAMETER_VALUE_POLICY_ERROR => 2306,
241             UNIMPLEMENTED_OBJECT_SERVICE => 2307,
242             DATA_MANAGEMENT_POLICY_VIOLATION => 2308,
243             COMMAND_FAILED => 2400, ## Internal server error not related to the protocol
244             COMMAND_FAILED_CLOSING => 2500, ## Same + connection dropped
245             AUTHENTICATION_ERROR_CLOSING => 2501,
246             SESSION_LIMIT_EXCEEDED_CLOSING => 2502,
247             );
248              
249             sub new
250             {
251 18     18 1 1789 my ($class,$type,$code,$eppcode,$is_success,$message,$lang,$info)=@_;
252 18 100 100     209 my %s=(
      100        
      100        
253             is_success => (defined $is_success && $is_success)? 1 : 0,
254             native_code => $code,
255             message => $message || '',
256             type => $type, ## rrp/epp/afnic/etc...
257             lang => $lang || '?',
258             'next' => undef,
259             data => {},
260             count => 0,
261             );
262              
263 18         39 $s{code}=_eppcode($type,$code,$eppcode,$s{is_success});
264 18 50 33     54 $s{info}=(defined $info && ref $info eq 'ARRAY')? $info : [];
265 18         25 bless(\%s,$class);
266 18         40 return \%s;
267             }
268              
269             sub trid
270             {
271 10     10 1 8 my $self=shift;
272 10 50 33     62 return unless (exists($self->{trid}) && (ref($self->{trid}) eq 'ARRAY'));
273 0 0       0 return wantarray()? @{$self->{trid}} : $self->{trid}->[0];
  0         0  
274             }
275              
276             sub clone
277             {
278 0     0 0 0 my ($self)=@_;
279 0         0 my $new={ %$self };
280 0 0       0 $new->{'next'}=$new->{'next'}->clone() if defined $new->{'next'};
281             ## we do not clone "data" key as it is supposed to be used read-only anyway, otherwise use Net::DRI::Util::deepcopy
282 0         0 bless($new,ref $self);
283 0         0 return $new;
284             }
285              
286 12     12 0 31 sub local_is_success { return shift->{is_success}; }
287              
288 1     1 0 1 sub local_get_extended_results { return @{shift->{info}}; }
  1         3  
289              
290             sub local_get_data
291             {
292 0     0 0 0 my ($self,$k1,$k2,$k3)=@_;
293 0 0 0     0 if (! defined $k1 || (defined $k3 xor defined $k2)) { Net::DRI::Exception::err_insufficient_parameters('get_data() expects one or three parameters'); }
  0   0     0  
294 0         0 my $d=$self->{'data'};
295              
296             ## 3 parameters form, walk the whole references tree
297 0 0 0     0 if (defined $k2 && defined $k3)
298             {
299 0         0 ($k1,$k2)=Net::DRI::Util::normalize_name($k1,$k2);
300 0 0       0 if (! exists $d->{$k1}) { return; }
  0         0  
301 0 0       0 if (! exists $d->{$k1}->{$k2}) { return; }
  0         0  
302 0 0       0 if (! exists $d->{$k1}->{$k2}->{$k3}) { return; }
  0         0  
303 0         0 return $d->{$k1}->{$k2}->{$k3};
304             }
305              
306             ## 1 parameter form, go directly to leafs if not too much of them (we skip session/exchange + message/info)
307 0 0       0 my @k=grep { $_ ne 'session' && $_ ne 'message' } keys %$d;
  0         0  
308 0 0       0 if (@k != 1) { return; }
  0         0  
309 0         0 $d=$d->{$k[0]};
310 0 0       0 if ( keys(%$d) != 1 ) { return; }
  0         0  
311 0         0 ($d)=values %$d;
312 0 0       0 if (! exists $d->{$k1}) { return; }
  0         0  
313 0         0 return $d->{$k1};
314             }
315              
316             sub _rh2a
317             {
318 0     0   0 my ($in)=@_;
319 0 0       0 return $in unless wantarray;
320 0         0 my @r=sort { $a cmp $b } keys %$in;
  0         0  
321 0         0 return @r;
322             }
323              
324             sub local_get_data_collection
325             {
326 0     0 0 0 my ($self,$k1,$k2)=@_;
327 0         0 my $d=$self->{'data'};
328              
329 0 0       0 if (! defined $k1) { return _rh2a($d); }
  0         0  
330 0         0 ($k1,undef)=Net::DRI::Util::normalize_name($k1,'');
331 0 0       0 if (! exists $d->{$k1}) { return; }
  0         0  
332 0 0       0 if (! defined $k2) { return _rh2a($d->{$k1}); }
  0         0  
333 0         0 ($k1,$k2)=Net::DRI::Util::normalize_name($k1,$k2);
334 0 0       0 if (! exists $d->{$k1}->{$k2}) { return; }
  0         0  
335 0         0 return _rh2a($d->{$k1}->{$k2});
336             }
337              
338             sub is_success
339             {
340 10     10 1 2310 my ($self)=@_;
341 10         24 while (defined $self)
342             {
343 10         16 my $is=$self->local_is_success();
344 10 100       23 return 0 unless $is;
345 9         45 } continue { $self=$self->next(); }
346 9         66 return 1;
347             }
348              
349             sub get_extended_results
350             {
351 0     0 1 0 my ($self)=@_;
352 0         0 my @i;
353 0         0 while (defined $self)
354             {
355 0         0 my @li=$self->local_get_extended_results();
356 0 0       0 push @i,@li if @li;
357 0         0 } continue { $self=$self->next(); }
358 0         0 return @i;
359             }
360              
361             sub get_data
362             {
363 0     0 1 0 my ($self,$k1,$k2,$k3)=@_;
364 0         0 my $r;
365 0         0 while (defined $self)
366             {
367 0         0 my $lr=$self->local_get_data($k1,$k2,$k3);
368 0 0       0 $r=$lr if defined $lr;
369 0         0 } continue { $self=$self->next(); }
370 0         0 return $r;
371             }
372              
373             sub get_data_collection
374             {
375 0     0 1 0 my ($self,$k1,$k2)=@_;
376 0 0       0 if (wantarray)
377             {
378 0         0 my %r;
379 0         0 while (defined $self)
380             {
381 0         0 foreach my $lr ($self->local_get_data_collection($k1,$k2)) { $r{$lr}=1; }
  0         0  
382 0         0 } continue { $self=$self->next(); }
383 0         0 my @r=sort { $a cmp $b } keys %r;
  0         0  
384 0         0 return @r;
385             } else
386             {
387 0         0 my @r;
388 0 0       0 my $deep=(defined $k1 ? 1 : 0)+(defined $k2 ? 1 : 0); ## 0,1,2
    0          
389 0         0 while (defined $self)
390             {
391 0         0 my $lr=$self->local_get_data_collection($k1,$k2);
392 0 0       0 push @r,$lr if defined $lr;
393 0         0 } continue { $self=$self->next(); }
394 0         0 return _merge($deep,@r);
395             }
396             }
397              
398             sub _merge
399             {
400 15     15   1293 my ($deep,@hashes)=@_;
401              
402             ## If we are "down below", just return the "last" set of values encountered (no merge)
403 15 100       30 return $hashes[-1] if ($deep==2);
404              
405 4         4 my %r;
406             my %tmp;
407 4         5 foreach my $rh (@hashes)
408             {
409 9         16 foreach my $key (sort { $a cmp $b } keys %$rh)
  10         11  
410             {
411 18         10 push @{$tmp{$key}},$rh->{$key};
  18         36  
412             }
413             }
414 4         8 foreach my $key (sort { $a cmp $b } keys %tmp)
  10         8  
415             {
416 12         7 $r{$key}=_merge($deep+1,@{$tmp{$key}});
  12         18  
417             }
418 4         10 return \%r;
419             }
420              
421 0     0 0 0 sub last { my $self=shift; while ( defined $self->next() ) { $self=$self->next(); } return $self; } ## no critic (Subroutines::ProhibitBuiltinHomonyms)
  0         0  
  0         0  
  0         0  
422              
423             ## These methods are not public !
424 10     10   13 sub _set_trid { my ($self,$v)=@_; $self->{'trid'}=$v; return; }
  10         11  
  10         14  
425 0     0   0 sub _set_last { my ($self,$v)=@_; while ( defined $self->next() ) { $self->{'count'}++; $self=$self->next(); } $self->{'count'}++; $self->{'next'}=$v; return; }
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
426 10     10   12 sub _set_data { my ($self,$v)=@_; $self->{'data'}=$v; return; }
  10         11  
  10         15  
427             sub _eppcode
428             {
429 18     18   25 my ($type,$code,$eppcode,$is_success)=@_;
430 18 100 33     91 return $EPP_CODES{COMMAND_FAILED} unless defined $type && $type && defined $code;
      66        
431 17 100 100     50 $eppcode=$code if (! defined $eppcode && $type eq 'epp');
432 17 100       34 return $is_success? $EPP_CODES{COMMAND_SUCCESSFUL} : $EPP_CODES{COMMAND_FAILED} unless defined $eppcode;
    100          
433 15 50       78 return $eppcode if $eppcode=~m/^\d{4}$/;
434 0 0       0 return exists $EPP_CODES{$eppcode} ? $EPP_CODES{$eppcode} : $EPP_CODES{COMMAND_FAILED};
435             }
436              
437             ## ($code,$msg,$lang,$ri) or ($msg,$lang,$ri)
438 2 50 33 2 0 5 sub new_success { my ($class,@p)=@_; return $class->new('epp',$EPP_CODES{(@p && defined $p[0] && $p[0]=~m/^[A-Z_]+$/ && exists $EPP_CODES{$p[0]})? shift(@p) : 'COMMAND_SUCCESSFUL'},undef,1,@p); }
  2         31  
439 0     0 0 0 sub new_error { my ($class,$code,@p)=@_; return $class->new('epp',$code,undef,0,@p); }
  0         0  
440              
441             sub local_as_string
442             {
443 2     2 0 2 my ($self,$withinfo)=@_;
444 2 50       4 my $r=sprintf('%s %d %s',$self->local_is_success()? 'SUCCESS' : 'ERROR',$self->code(),length $self->message() ? ($self->code() eq $self->native_code()? $self->message() : $self->message().' ['.$self->native_code().']') : '(No message given)');
    50          
    50          
445 2 100 66     36 if (defined $withinfo && $withinfo)
446             {
447 1         3 my @i=$self->local_get_extended_results();
448 1 0       3 $r.="\n".join("\n",map { my $rh=$_; "\t".(join(' ',map { $_.'='.(defined $rh->{$_} ? $rh->{$_} : '') } sort { $a cmp $b } keys %$rh)) } @i) if @i;
  0 50       0  
  0         0  
  0         0  
  0         0  
449             }
450 2         3 return $r;
451             }
452              
453             sub as_string
454             {
455 2     2 1 734 my ($self,$withinfo)=@_;
456 2         2 my @r;
457 2         5 while (defined $self)
458             {
459 2         4 push @r,$self->local_as_string($withinfo);
460 2         5 } continue { $self=$self->next(); }
461 2 50       15 return wantarray ? @r : (@r==1 ? $r[0] : join("\n",map { sprintf('{%d} %s',1+$_,$r[$_]) } (0..$#r)));
  0 50       0  
462             }
463              
464 0 0 0 0 1 0 sub print { my ($self,$e)=@_; print $self->as_string(defined $e && $e ? 1 : 0); return; } ## no critic (Subroutines::ProhibitBuiltinHomonyms)
  0         0  
  0         0  
465              
466             ## Should these be global too ? if so, enhance is() with third parameter to know if walking is necessary or not
467 0     0 1 0 sub is_pending { my ($self)=@_; return $self->is('COMMAND_SUCCESSFUL_PENDING'); }
  0         0  
468 10   33 10 1 11 sub is_closing { my ($self)=@_; return $self->is('COMMAND_SUCCESSFUL_END') || $self->is('COMMAND_FAILED_CLOSING') || $self->is('AUTHENTICATION_ERROR_CLOSING') || $self->is('SESSION_LIMIT_EXCEEDED_CLOSING'); }
  10         15  
469              
470             sub is
471             {
472 40     40 1 40 my ($self,$symcode)=@_;
473 40 50 33     127 Net::DRI::Exception::err_insufficient_parameters('Net::DRI::Protocol::ResultStatus->is() method expects a symbolic name') unless defined $symcode && length $symcode;
474 40 50       72 Net::DRI::Exception::err_invalid_parameters('Symbolic name "'.$symcode.'" does not exist in Net::DRI::Protocol::ResultStatus') unless exists $EPP_CODES{$symcode};
475 40 50       90 my $code=ref $self ? $self->code() : $self;
476 40 50 33     247 Net::DRI::Exception::err_invalid_parameters('Undefined or malformed code') unless defined $code && $code=~m/^\d+$/;
477 40 50       179 return ($code == $EPP_CODES{$symcode})? 1 : 0;
478             }
479              
480             ####################################################################################################
481             1;