File Coverage

blib/lib/Net/DRI/Protocol/RRI/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, RRI Message
2             ##
3             ## Copyright (c) 2007-2009,2013 Tonnerre Lombard . 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::RRI::Message;
16              
17 2     2   7 use strict;
  2         4  
  2         52  
18 2     2   7 use warnings;
  2         2  
  2         38  
19              
20 2     2   385 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 command command_body cltrid svtrid result
28             errcode errmsg node_resdata result_extra_info));
29              
30             =pod
31              
32             =head1 NAME
33              
34             Net::DRI::Protocol::RRI::Message - RRI Message for Net::DRI
35              
36             =head1 DESCRIPTION
37              
38             Please see the README file for details.
39              
40             =head1 SUPPORT
41              
42             For now, support questions should be sent to:
43              
44             Etonnerre.lombard@sygroup.chE
45              
46             Please also see the SUPPORT file in the distribution.
47              
48             =head1 SEE ALSO
49              
50             Ehttp://oss.bsdprojects.net/projects/netdri/E
51              
52             =head1 AUTHOR
53              
54             Tonnerre Lombard, Etonnerre.lombard@sygroup.chE
55              
56             =head1 COPYRIGHT
57              
58             Copyright (c) 2007-2009,2013 Tonnerre Lombard .
59             All rights reserved.
60              
61             This program is free software; you can redistribute it and/or modify
62             it under the terms of the GNU General Public License as published by
63             the Free Software Foundation; either version 2 of the License, or
64             (at your option) any later version.
65              
66             See the LICENSE file that comes with this distribution for more details.
67              
68             =cut
69              
70             ####################################################################################################
71              
72             sub new
73             {
74             my $class = shift;
75             my $trid = shift;
76              
77             my $self = {
78             result => 'uninitialized',
79             };
80              
81             bless($self,$class);
82              
83             $self->cltrid($trid) if (defined($trid) && $trid);
84             return $self;
85             }
86              
87             sub ns
88             {
89             my ($self,$what)=@_;
90             return $self->{ns} unless defined($what);
91              
92             if (ref($what) eq 'HASH')
93             {
94             $self->{ns}=$what;
95             return $what;
96             }
97             return unless exists($self->{ns}->{$what});
98             return $self->{ns}->{$what}->[0];
99             }
100              
101             sub is_success { return (shift->result() =~ m/^success/)? 1 : 0; }
102              
103             sub result_status
104             {
105             my $self=shift;
106             my $rs = Net::DRI::Protocol::ResultStatus->new('rri',
107             ($self->is_success() ? 1000 : $self->errcode()), undef,
108             $self->is_success(), $self->errmsg(), 'en',
109             $self->result_extra_info());
110             $rs->_set_trid([ $self->cltrid(), $self->svtrid() ]);
111             return $rs;
112             }
113              
114             sub as_string
115             {
116             my ($self)=@_;
117             my $rns=$self->ns();
118             my $topns=$rns->{_main};
119             my $ens=sprintf('xmlns="%s"', $topns->[0]);
120             my $cmdi = $self->command();
121             my @d;
122             push @d,'';
123             my ($type, $cmd, $ns, $attr);
124             ($type, $cmd, $ns, $attr) = @{$cmdi} if (ref($cmdi) eq 'ARRAY');
125              
126             $attr = '' unless (defined($attr));
127             $attr = ' ' . join(' ', map { $_ . '="' . $attr->{$_} . '"' }
128             sort { $a cmp $b } keys (%{$attr})) if (ref($attr) eq 'HASH');
129              
130             if (defined($ns))
131             {
132             if (ref($ns) eq 'HASH')
133             {
134             $ens .= ' ' . join(' ', map { 'xmlns:' . $_ . '="' . $ns->{$_} . '"' }
135             sort { $a cmp $b } keys(%{$ns}));
136             $cmd = $type . ':' . $cmd;
137             }
138             else
139             {
140             $ens .= ' xmlns:' . $type . '="' . $ns . '"';
141             $cmd = $type . ':' . $cmd;
142             }
143             }
144             else
145             {
146             $cmd = $type;
147             $type = undef;
148             }
149              
150             push @d,'';
151              
152             my $body=$self->command_body();
153             if (defined($body) && $body)
154             {
155             push @d,'<'.$cmd.$attr.'>';
156             push @d,Net::DRI::Util::xml_write($body);
157             push @d,'';
158             } else
159             {
160             push @d,'<'.$cmd.$attr.'/>';
161             }
162            
163             ## OPTIONAL clTRID
164             my $cltrid=$self->cltrid();
165             push @d,''.$cltrid.''
166             if (defined($cltrid) && $cltrid &&
167             Net::DRI::Util::xml_is_token($cltrid,3,64));
168             push @d,'';
169              
170             return join('',@d);
171             }
172              
173             sub topns { return shift->ns->{_main}->[0]; }
174              
175             sub get_content
176             {
177             my ($self,$nodename,$ns,$ext)=@_;
178             return unless (defined($nodename) && $nodename);
179              
180             my @tmp;
181             my $n1=$self->node_resdata();
182              
183             $ns||=$self->topns();
184              
185             @tmp=$n1->getElementsByTagNameNS($ns,$nodename) if (defined($n1));
186              
187             return unless @tmp;
188             return wantarray()? @tmp : $tmp[0];
189             }
190              
191             sub parse
192             {
193             my ($self,$dc,$rinfo)=@_;
194             my $NS=$self->topns();
195             my $trNS = $self->ns('tr');
196             my $parser=XML::LibXML->new();
197             my $xstr = $dc->as_string();
198             $xstr =~ s/^\s*//;
199             my $doc=$parser->parse_string($xstr);
200             my $root=$doc->getDocumentElement();
201             Net::DRI::Exception->die(0, 'protocol/RRI', 1,
202             'Unsuccessfull parse, root element is not registry-response')
203             unless ($root->getName() eq 'registry-response');
204              
205             my @trtags = $root->getElementsByTagNameNS($trNS, 'transaction');
206             Net::DRI::Exception->die(0, 'protocol/RRI', 1,
207             'Unsuccessfull parse, no transaction block') unless (@trtags);
208             my $res = $trtags[0];
209              
210             ## result block(s)
211             my @results = $res->getElementsByTagNameNS($trNS,'result'); ## success indicator
212             foreach (@results)
213             {
214             $self->result($_->firstChild()->getData());
215             }
216              
217             if ($res->getElementsByTagNameNS($trNS,'message')) ## OPTIONAL
218             {
219             my @msgs = $res->getElementsByTagNameNS($trNS,'message');
220             my $msg = $msgs[0];
221             my @extra = ();
222              
223             if (defined($msg))
224             {
225             my @texts = $msg->getElementsByTagNameNS($trNS, 'text');
226             my $msgtype = $msg->getAttribute('level');
227             my $text = $texts[0];
228              
229             if ($msgtype eq 'error')
230             {
231             $self->errcode($msg->getAttribute('code'));
232             $self->errmsg($text->getFirstChild()->getData()) if (defined($text));
233             }
234             else
235             {
236             push @extra, { from => 'rri', type => 'text', code => $msg->getAttribute('code'), message => (defined $text ? $text->textContent() : '') };
237             }
238             }
239             $self->result_extra_info(\@extra);
240             }
241              
242             if ($res->getElementsByTagNameNS($trNS,'data')) ## OPTIONAL
243             {
244             $self->node_resdata(($res->getElementsByTagNameNS($trNS,'data'))[0]);
245             }
246              
247             ## trID
248             if ($res->getElementsByTagNameNS($trNS, 'stid'))
249             {
250             my @svtrid = $res->getElementsByTagNameNS($trNS, 'stid');
251             $self->svtrid($svtrid[0]->firstChild()->getData());
252             }
253             if ($res->getElementsByTagNameNS($trNS, 'ctid'))
254             {
255             my @cltrid = $res->getElementsByTagNameNS($trNS, 'ctid');
256             $self->cltrid($cltrid[0]->firstChild()->getData());
257             }
258              
259             return;
260             }
261              
262             ####################################################################################################
263             1;
264