File Coverage

blib/lib/Net/DRI/Protocol/EPP/Message.pm
Criterion Covered Total %
statement 16 18 88.8
branch n/a
condition n/a
subroutine 6 6 100.0
pod n/a
total 22 24 91.6


line stmt bran cond sub pod time code
1             ## Domain Registry Interface, EPP Message
2             ##
3             ## Copyright (c) 2005-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::EPP::Message;
16              
17 68     68   2699 use utf8;
  68         106  
  68         407  
18 68     68   1719 use strict;
  68         86  
  68         1086  
19 68     68   215 use warnings;
  68         82  
  68         1392  
20              
21 68     68   2221 use DateTime::Format::ISO8601 ();
  68         372419  
  68         960  
22 68     68   237 use DateTime ();
  68         81  
  68         835  
23 68     68   17341 use XML::LibXML ();
  0            
  0            
24              
25             use Net::DRI::Protocol::ResultStatus;
26             use Net::DRI::Exception;
27             use Net::DRI::Util;
28             use Net::DRI::Protocol::EPP::Util;
29             use Net::DRI::Util;
30              
31             use base qw(Class::Accessor::Chained::Fast Net::DRI::Protocol::Message);
32             __PACKAGE__->mk_accessors(qw(version command command_body cltrid svtrid msg_id node_resdata node_extension node_msg node_greeting operation));
33              
34             =pod
35              
36             =head1 NAME
37              
38             Net::DRI::Protocol::EPP::Message - EPP Message for Net::DRI
39              
40             =head1 DESCRIPTION
41              
42             Please see the README file for details.
43              
44             =head1 SUPPORT
45              
46             For now, support questions should be sent to:
47              
48             Enetdri@dotandco.comE
49              
50             Please also see the SUPPORT file in the distribution.
51              
52             =head1 SEE ALSO
53              
54             Ehttp://www.dotandco.com/services/software/Net-DRI/E
55              
56             =head1 AUTHOR
57              
58             Patrick Mevzek, Enetdri@dotandco.comE
59              
60             =head1 COPYRIGHT
61              
62             Copyright (c) 2005-2014 Patrick Mevzek .
63             All rights reserved.
64              
65             This program is free software; you can redistribute it and/or modify
66             it under the terms of the GNU General Public License as published by
67             the Free Software Foundation; either version 2 of the License, or
68             (at your option) any later version.
69              
70             See the LICENSE file that comes with this distribution for more details.
71              
72             =cut
73              
74             ####################################################################################################
75              
76             sub new
77             {
78             my ($class,$trid,$otype,$oaction)=@_;
79             my $self={ results => [], ns => {} };
80             bless($self,$class);
81              
82             $self->cltrid($trid) if (defined $trid && length $trid);
83             $self->operation([$otype,$oaction]);
84             return $self;
85             }
86              
87             sub _get_result
88             {
89             my ($self,$what,$pos)=@_;
90             my $rh=$self->{results}->[defined $pos ? $pos : 0];
91             return unless (defined $rh && ref $rh eq 'HASH' && keys(%$rh)==4);
92             return $rh->{$what};
93             }
94              
95             sub results { return @{shift->{results}}; }
96             sub results_code { return map { $_->{code} } shift->results(); }
97             sub results_message { return map { $_->{message} } shift->results(); }
98             sub results_lang { return map { $_->{lang} } shift->results(); }
99             sub results_extra_info { return map { $_->{extra_info} } shift->results(); }
100              
101             sub result_is { my ($self,$code)=@_; return Net::DRI::Protocol::ResultStatus::is($self->_get_result('code'),$code); }
102             sub result_code { my ($self,@args)=@_; return $self->_get_result('code',@args); }
103             sub result_message { my ($self,@args)=@_; return $self->_get_result('message',@args); }
104             sub result_lang { my ($self,@args)=@_; return $self->_get_result('lang',@args); }
105             sub result_extra_info { my ($self,@args)=@_; return $self->_get_result('extra_info',@args); }
106              
107             sub ns
108             {
109             my ($self,$what)=@_;
110             return $self->{ns} unless defined $what;
111              
112             if (ref $what eq 'HASH')
113             {
114             $self->{ns}=$what;
115             return $what;
116             }
117             return unless exists $self->{ns}->{$what};
118             return $self->{ns}->{$what}->[0];
119             }
120              
121             sub nsattrs
122             {
123             my ($self,$what)=@_;
124             return unless defined $what;
125             my @d=sort { $a cmp $b } grep { defined $_ && exists $self->{ns}->{$_} } (ref $what eq 'ARRAY' ? @$what : ($what));
126             return unless @d;
127              
128             if (wantarray)
129             {
130             my @r;
131             foreach my $rdd (@d)
132             {
133             my @dd=@{$self->{ns}->{$rdd}};
134             push @r,$dd[0],$dd[0],$dd[1];
135             }
136             return @r;
137             } else
138             {
139             my (@xns,@xsl);
140             foreach my $rdd (@d)
141             {
142             my @dd=@{$self->{ns}->{$rdd}};
143             push @xns,sprintf('xmlns:%s="%s"',$rdd,$dd[0]);
144             push @xsl,sprintf('%s %s',$dd[0],$dd[1]);
145             }
146             return join(' ',@xns).' xsi:schemaLocation="'.join(' ',@xsl).'"';
147             }
148             }
149              
150             sub is_success { return _is_success(shift->result_code()); }
151             sub _is_success { return (shift=~m/^1/)? 1 : 0; } ## 1XXX is for success, 2XXX for failures
152              
153             sub result_status
154             {
155             my ($self)=@_;
156             my @rs;
157              
158             foreach my $result (@{$self->{results}})
159             {
160             my $rs=Net::DRI::Protocol::ResultStatus->new('epp',$result->{code},undef,_is_success($result->{code}),$result->{message},$result->{lang},$result->{extra_info});
161             $rs->_set_trid([ $self->cltrid(),$self->svtrid() ]);
162             push @rs,$rs;
163             }
164             return Net::DRI::Util::link_rs(@rs);
165             }
166              
167             sub command_extension_register
168             {
169             my ($self,$ocmd,$ons,$otherattrs)=@_;
170              
171             $self->{extension}=[] unless exists $self->{extension};
172             my $eid=1+$#{$self->{extension}};
173             if (defined $ons && $ons!~m/xmlns/) ## new interface, everything should switch to that (TODO)
174             {
175             my ($nss,$command)=($ocmd,$ons);
176             $ocmd=(ref $nss eq 'ARRAY' ? $nss->[0] : $nss).':'.$command;
177             $ons=$self->nsattrs($nss);
178             ## This is used for other *generic* attributes, not for xmlns: ones !
179             $ons.=' '.join(' ',map { sprintf('%s="%s"',$_,$otherattrs->{$_}) } sort { $a cmp $b } keys %$otherattrs) if defined $otherattrs && ref $otherattrs eq 'HASH' && keys %$otherattrs;
180             }
181             $self->{extension}->[$eid]=[$ocmd,$ons,[]];
182             return $eid;
183             }
184              
185             sub command_extension
186             {
187             my ($self,$eid,$rdata)=@_;
188              
189             if (defined $eid && $eid >= 0 && $eid <= $#{$self->{extension}} && defined $rdata && (((ref $rdata eq 'ARRAY') && @$rdata) || ($rdata ne '')))
190             {
191             $self->{extension}->[$eid]->[2]=(ref($rdata) eq 'ARRAY')? [ @{$self->{extension}->[$eid]->[2]}, @$rdata ] : $rdata;
192             }
193             return $self->{extension};
194             }
195              
196             sub as_string
197             {
198             my ($self,$protect)=@_;
199             my @d;
200             push @d,'';
201             push @d,'nsattrs('_main')).'>';
202              
203             my ($cmd,$ocmd,$ons);
204             my $rc=$self->command();
205             ($cmd,$ocmd,$ons)=@$rc if (defined $rc && ref $rc);
206              
207             my $attr='';
208             ($cmd,$attr)=($cmd->[0],' '.join(' ',map { $_.'="'.$cmd->[1]->{$_}.'"' } sort { $a cmp $b } keys(%{$cmd->[1]}))) if (defined $cmd && ref $cmd);
209              
210             if (defined $cmd)
211             {
212             push @d,'' if ($cmd ne 'hello');
213             my $body=$self->command_body();
214              
215             if (!defined $ocmd && !defined $body)
216             {
217             push @d,'<'.$cmd.$attr.'/>';
218             } else
219             {
220             push @d,'<'.$cmd.$attr.'>';
221             if (defined $body && length $body)
222             {
223             push @d,(defined $ocmd && length $ocmd)? ('<'.$ocmd.' '.$ons.'>',Net::DRI::Util::xml_write($body),'') : Net::DRI::Util::xml_write($body);
224             } else
225             {
226             push @d,'<'.$ocmd.' '.$ons.'/>';
227             }
228             push @d,'';
229             }
230             }
231              
232             ## OPTIONAL extension
233             my $ext=$self->{extension};
234             if (defined $ext && ref $ext eq 'ARRAY' && @$ext)
235             {
236             push @d,'';
237             foreach my $e (@$ext)
238             {
239             my ($ecmd,$ens,$rdata)=@$e;
240             if ($ecmd && $ens)
241             {
242             if ((ref $rdata && @$rdata) || (! ref $rdata && $rdata ne ''))
243             {
244             push @d,'<'.$ecmd.' '.$ens.'>';
245             push @d,ref($rdata)? Net::DRI::Util::xml_write($rdata) : Net::DRI::Util::xml_escape($rdata);
246             push @d,'';
247             } else
248             {
249             push @d,'<'.$ecmd.' '.$ens.'/>';
250             }
251             } else
252             {
253             push @d,Net::DRI::Util::xml_escape(@$rdata);
254             }
255             }
256             push @d,'';
257             }
258              
259             ## OPTIONAL clTRID
260             my $cltrid=$self->cltrid();
261             if (defined $cmd && $cmd ne 'hello')
262             {
263             push @d,''.$cltrid.'' if (defined $cltrid && Net::DRI::Util::xml_is_token($cltrid,3,64));
264             push @d,'';
265             }
266             push @d,'';
267              
268             my $msg=join('',@d);
269              
270             if (defined $protect && ref $protect eq 'HASH')
271             {
272             if (exists $protect->{session_password} && $protect->{session_password})
273             {
274             $msg=~s#(?<=)(\S+?)#''.('*' x length $1).''#e;
275             $msg=~s#(?<=)(\S+?)#''.('*' x length $1).''#e;
276             }
277             }
278              
279             return $msg;
280             }
281              
282             sub get_response { my ($self,@args)=@_; return $self->_get_content($self->node_resdata(),@args); }
283             sub get_extension { my ($self,@args)=@_; return $self->_get_content($self->node_extension(),@args); }
284              
285             sub _get_content
286             {
287             my ($self,$node,$nstag,$nodename)=@_;
288             return unless (defined $node && defined $nstag && length $nstag && defined $nodename && length $nodename);
289             my $ns=$self->ns($nstag);
290             $ns=$nstag unless defined $ns && $ns;
291             my @tmp=$node->getChildrenByTagNameNS($ns,$nodename);
292             return unless @tmp;
293             return $tmp[0];
294             }
295              
296             sub parse
297             {
298             my ($self,$dc,$rinfo)=@_;
299              
300             my $NS=$self->ns('_main');
301             my $parser=XML::LibXML->new();
302             my $doc=$parser->parse_string($dc->as_string());
303             my $root=$doc->getDocumentElement();
304             Net::DRI::Exception->die(0,'protocol/EPP',1,'Unsuccessfull parse, root element is not epp') unless ($root->localname() eq 'epp');
305              
306             if (my $g=$root->getChildrenByTagNameNS($NS,'greeting'))
307             {
308             push @{$self->{results}},{ code => 1000, message => 'Greeting message received', lang => 'en', extra_info => []}; ## fake an OK
309             $self->node_greeting($g->get_node(1));
310             return;
311             }
312              
313             my $c=$root->getChildrenByTagNameNS($NS,'response');
314             Net::DRI::Exception->die(0,'protocol/EPP',1,'Unsuccessfull parse, expected exactly one response block') unless ($c->size()==1);
315              
316             ## result block(s)
317             my $res=$c->get_node(1);
318             foreach my $result ($res->getChildrenByTagNameNS($NS,'result')) ## one element if success, multiple elements if failure RFC5730 ยง2.6
319             {
320             push @{$self->{results}},Net::DRI::Protocol::EPP::Util::parse_node_result($result,$NS);
321             }
322              
323             $rinfo->{message}->{info}={ count => 0, checked_on => DateTime->now() };
324             $c=$res->getChildrenByTagNameNS($NS,'msgQ');
325             if ($c->size()) ## OPTIONAL
326             {
327             my $msgq=$c->get_node(1);
328             my $id=$msgq->getAttribute('id'); ## id of the message that has just been retrieved and dequeued (RFC5730/RFC4930) OR id of *next* available message (RFC3730)
329             $rinfo->{message}->{info}->{id}=$id;
330             $rinfo->{message}->{info}->{count}=$msgq->getAttribute('count');
331             if ($msgq->hasChildNodes()) ## We will have childs only as a result of a poll request
332             {
333             my %d=( id => $id );
334             $self->msg_id($id);
335              
336             my $qdate=Net::DRI::Util::xml_child_content($msgq,$NS,'qDate');
337             eval { $d{qdate}=DateTime::Format::ISO8601->new()->parse_datetime($qdate) if defined $qdate && length $qdate; };
338              
339             my $msg=$msgq->getChildrenByTagNameNS($NS,'msg');
340             if ($msg->size())
341             {
342             my $msgc=$msg->get_node(1);
343             $d{lang}=$msgc->getAttribute('lang') || 'en';
344             if (grep { $_->nodeType() == 1 } $msgc->childNodes())
345             {
346             $d{content}=$msgc->toString();
347             $self->node_msg($msgc);
348             } else
349             {
350             $d{content}=$msgc->textContent();
351             }
352             }
353             $rinfo->{message}->{$id}=\%d;
354             }
355             }
356              
357             $c=$res->getChildrenByTagNameNS($NS,'resData');
358             $self->node_resdata($c->get_node(1)) if ($c->size()); ## OPTIONAL
359             $c=$res->getChildrenByTagNameNS($NS,'extension');
360             $self->node_extension($c->get_node(1)) if ($c->size()); ## OPTIONAL
361              
362             ## trID
363             my $trid=$res->getChildrenByTagNameNS($NS,'trID')->get_node(1); ## we search only for as direct child of , hence getChildren and not getElements !
364             my $tmp=Net::DRI::Util::xml_child_content($trid,$NS,'clTRID');
365             $self->cltrid($tmp) if defined $tmp;
366             $tmp=Net::DRI::Util::xml_child_content($trid,$NS,'svTRID');
367             $self->svtrid($tmp) if defined $tmp;
368             return;
369             }
370              
371             sub add_to_extra_info
372             {
373             my ($self,$data)=@_;
374             push @{$self->{results}->[-1]->{extra_info}},$data;
375             return;
376             }
377              
378             ####################################################################################################
379             1;