File Coverage

blib/lib/Net/DRI/Protocol/OpenSRS/XCP/Message.pm
Criterion Covered Total %
statement 7 9 77.7
branch n/a
condition n/a
subroutine 3 3 100.0
pod n/a
total 10 12 83.3


line stmt bran cond sub pod time code
1             ## Domain Registry Interface, OpenSRS XCP Message
2             ##
3             ## Copyright (c) 2008-2010,2012-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::OpenSRS::XCP::Message;
16              
17 2     2   9 use strict;
  2         4  
  2         57  
18 2     2   8 use warnings;
  2         2  
  2         49  
19              
20 2     2   459 use XML::LibXML ();
  0            
  0            
21              
22             use Net::DRI::Protocol::ResultStatus;
23             use Net::DRI::Exception;
24             use Net::DRI::Util;
25              
26             use base qw(Class::Accessor::Chained::Fast Net::DRI::Protocol::Message);
27             __PACKAGE__->mk_accessors(qw(version client_auth command command_attributes response_attributes response_code response_text response_is_success));
28              
29             =pod
30              
31             =head1 NAME
32              
33             Net::DRI::Protocol::OpenSRS::XCP::Message - OpenSRS XCP Message for Net::DRI
34              
35             =head1 DESCRIPTION
36              
37             Please see the README file for details.
38              
39             =head1 SUPPORT
40              
41             For now, support questions should be sent to:
42              
43             Enetdri@dotandco.comE
44              
45             Please also see the SUPPORT file in the distribution.
46              
47             =head1 SEE ALSO
48              
49             Ehttp://www.dotandco.com/services/software/Net-DRI/E
50              
51             =head1 AUTHOR
52              
53             Patrick Mevzek, Enetdri@dotandco.comE
54              
55             =head1 COPYRIGHT
56              
57             Copyright (c) 2008-2010,2012-2014 Patrick Mevzek .
58             All rights reserved.
59              
60             This program is free software; you can redistribute it and/or modify
61             it under the terms of the GNU General Public License as published by
62             the Free Software Foundation; either version 2 of the License, or
63             (at your option) any later version.
64              
65             See the LICENSE file that comes with this distribution for more details.
66              
67             =cut
68              
69             ####################################################################################################
70              
71             sub new
72             {
73             my ($class,$trid)=@_;
74             my $self={ results => [], _body => '', command => {}};
75             bless($self,$class);
76              
77             $self->version('0.9');
78             return $self;
79             }
80              
81             our %CODES=( 200 => 1000,
82             210 => 2303,
83             211 => 2302,
84             212 => 1000,
85             221 => 2302,
86             250 => 1001,
87             300 => 1001,
88             310 => 2502,
89             350 => 2502, ## A maximum of 100 commands can be sent through one connection/session. After 100 commands have been submitted, the connection is closed and a new connection must be opened to submit outstanding requests.
90             400 => 2400,
91             404 => 2400,
92             405 => 2400,
93             410 => 2200,
94             415 => 2200,
95             430 => 2000,
96             435 => 2201,
97             436 => 2400,
98             437 => 2304,
99             440 => 2201,
100             445 => 2201,
101             447 => 2201,
102             460 => 2003,
103             465 => 2005,
104             480 => 2306,
105             485 => 2302,
106             486 => 2304,
107             487 => 2106,
108             541 => 2004,
109             552 => 2304,
110             555 => 2306,
111             557 => 2305,
112             705 => 2400,
113             );
114              
115             sub result_status
116             {
117             my $self=shift;
118             return Net::DRI::Protocol::ResultStatus->new_success($self->response_text()) if $self->response_is_success();
119             my $code=$self->response_code();
120             my $eppcode=(defined $code && exists $CODES{$code})? $CODES{$code} : 'COMMAND_FAILED';
121             return Net::DRI::Protocol::ResultStatus->new('opensrs_xcp',$code,$eppcode,$self->response_is_success(),$self->response_text(),'en');
122             }
123              
124             sub is_success { return shift->response_is_success(); }
125             sub as_string { return shift->get_body(); }
126              
127             sub get_body
128             {
129             my ($self)=@_;
130             return $self->{_body} if length($self->{_body});
131             my @d;
132             push @d,q{};
133             push @d,q{};
134             push @d,'';
135             push @d,'
',$self->version(),'
';
136             push @d,'';
137             push @d,'';
138             push @d,'';
139             my $d=$self->command(); ## ref hash with at least action & object keys, maybe more (such as cookie)
140             $d->{protocol}='XCP';
141             foreach my $k (sort { $a cmp $b } keys %$d)
142             {
143             push @d,'',$d->{$k},'';
144             }
145             push @d,'',_obj2dt($self->command_attributes()),'' if defined($self->command_attributes());
146             push @d,'';
147             push @d,'';
148             push @d,'';
149             push @d,'';
150              
151             $self->{_body}=join('',@d);
152             return $self->{_body};
153             }
154              
155             sub _obj2dt
156             {
157             my ($in)=@_;
158             my @r;
159             foreach my $el ($in)
160             {
161             my $ref=ref($el);
162             if (!$ref)
163             {
164             push @r,sprintf('%s',Net::DRI::Util::xml_escape($el));
165             } elsif ($ref eq 'HASH')
166             {
167             my @c;
168             foreach my $k (sort { $a cmp $b } keys %$el)
169             {
170             $k=~s/"/"/g;
171             my $v=$el->{$k};
172             if (!defined($v)) {
173             push @c,sprintf('',$k);
174             } else {
175             push @c,sprintf('%s',$k,ref($v)? _obj2dt($v) : Net::DRI::Util::xml_escape($v));
176             }
177             }
178             push @r,sprintf('%s',join('',@c));
179             } elsif ($ref eq 'ARRAY')
180             {
181             my @c;
182             foreach my $i (0..$#$el)
183             {
184             push @c,sprintf('%s',$i,ref($el->[$i])? _obj2dt($el->[$i]) : Net::DRI::Util::xml_escape($el->[$i]));
185             }
186             push @r,sprintf('%s',join('',@c));
187             } elsif ($ref eq 'SCALAR')
188             {
189             push @r,sprintf('%s',Net::DRI::Util::xml_escape($$el)); ## defined in specifications, but not really used ?
190             } else
191             {
192             Net::DRI::Exception::err_assert('_obj2dt cannot deal with data '.$el);
193             }
194             }
195             return @r;
196             }
197              
198             sub _dt2obj ## no critic (Subroutines::RequireFinalReturn)
199             {
200             my ($doc)=@_;
201             my $c=$doc->getFirstChild();
202             return unless defined($c);
203             while (defined($c) && $c->nodeType()!=1) { $c=$c->getNextSibling(); }
204             return $doc->textContent() unless (defined($c) && $c->nodeType()==1);
205             my $n=$c->nodeName();
206             if ($n eq 'dt_scalar')
207             {
208             return $c->textContent();
209             } elsif ($n eq 'dt_assoc')
210             {
211             my %r;
212             foreach my $item ($c->getChildrenByTagName('item'))
213             {
214             $r{$item->getAttribute('key')}=_dt2obj($item);
215             }
216             return \%r;
217             } elsif ($n eq 'dt_array')
218             {
219             my @r;
220             foreach my $item ($c->getChildrenByTagName('item'))
221             {
222             $r[$item->getAttribute('key')]=_dt2obj($item);
223             }
224             return \@r;
225             }
226              
227             Net::DRI::Exception::err_assert('_dt2obj ca not deal with node name '.$n);
228             }
229              
230             sub parse
231             {
232             my ($self,$dr,$rinfo,$otype,$oaction,$msgsent)=@_;
233             $self->command($msgsent->command()); ## Copy over for reference from message sent
234              
235             my $parser=XML::LibXML->new();
236             my $doc=$parser->parse_string($dr->as_string());
237             my $root=$doc->getDocumentElement();
238             Net::DRI::Exception->die(0,'protocol/OpenSRS/XCP',1,'Unsuccessful parse, root element is not OPS_envelope but '.$root->getName()) unless ($root->getName() eq 'OPS_envelope');
239              
240             my $db=$root->getElementsByTagName('data_block');
241             Net::DRI::Exception->die(0,'protocol/OpenSRS/XCP',1,'Unsuccessful parse, expected only one data_block node below root, found '.$db->size()) unless ($db->size()==1);
242             $db=$db->get_node(1)->getChildrenByTagName('dt_assoc');
243             Net::DRI::Exception->die(0,'protocol/OpenSRS/XCP',1,'Unsuccessful parse, expected one dt_assoc node directly below data_block, found '.$db->size()) unless ($db->size()==1);
244              
245             foreach my $item ($db->get_node(1)->getChildrenByTagName('item'))
246             {
247             my $key=$item->getAttribute('key');
248             next if ($key eq 'protocol' || $key eq 'action' || $key eq 'object'); ## protocol is XCP, action is always REPLY, and we already have object in command()
249             if ($key eq 'attributes') ## specific data about requested action, should always be an hash based on documentation
250             {
251             $self->response_attributes(_dt2obj($item));
252             next;
253             }
254             if ($key eq 'response_code') ## meaning is action-specific
255             {
256             $self->response_code($item->textContent());
257             next;
258             }
259             if ($key eq 'response_text') ## meaning is action-specific
260             {
261             $self->response_text($item->textContent());
262             next;
263             }
264             if ($key eq 'is_success') ## 0 if not successful, 1 if action was successful
265             {
266             $self->response_is_success($item->textContent());
267             next;
268             }
269             }
270             return;
271             }
272              
273             ####################################################################################################
274             1;