File Coverage

blib/lib/Net/DRI/Protocol/EPP/Core/RegistryMessage.pm
Criterion Covered Total %
statement 12 80 15.0
branch 0 28 0.0
condition 0 21 0.0
subroutine 4 9 44.4
pod 0 4 0.0
total 16 142 11.2


line stmt bran cond sub pod time code
1             ## Domain Registry Interface, EPP Registry messages commands (RFC5730)
2             ##
3             ## Copyright (c) 2006-2013,2015-2016 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::Core::RegistryMessage;
16              
17 1     1   959 use strict;
  1         2  
  1         29  
18 1     1   3 use warnings;
  1         2  
  1         23  
19              
20 1     1   4 use Net::DRI::Exception;
  1         1  
  1         17  
21 1     1   3 use Net::DRI::Util;
  1         1  
  1         700  
22              
23             =pod
24              
25             =head1 NAME
26              
27             Net::DRI::Protocol::EPP::Core::RegistryMessage - EPP Registry messages commands (RFC5730) for Net::DRI
28              
29             =head1 DESCRIPTION
30              
31             Please see the README file for details.
32              
33             =head1 SUPPORT
34              
35             For now, support questions should be sent to:
36              
37             Enetdri@dotandco.comE
38              
39             Please also see the SUPPORT file in the distribution.
40              
41             =head1 SEE ALSO
42              
43             Ehttp://www.dotandco.com/services/software/Net-DRI/E
44              
45             =head1 AUTHOR
46              
47             Patrick Mevzek, Enetdri@dotandco.comE
48              
49             =head1 COPYRIGHT
50              
51             Copyright (c) 2006-2013,2015-2016 Patrick Mevzek .
52             All rights reserved.
53              
54             This program is free software; you can redistribute it and/or modify
55             it under the terms of the GNU General Public License as published by
56             the Free Software Foundation; either version 2 of the License, or
57             (at your option) any later version.
58              
59             See the LICENSE file that comes with this distribution for more details.
60              
61             =cut
62              
63             ####################################################################################################
64              
65             sub register_commands
66             {
67 0     0 0   my ($class,$version)=@_;
68 0           my %tmp=(
69             retrieve => [ \&pollreq, \&parse_poll ],
70             delete => [ \&pollack ],
71             );
72              
73 0           return { 'message' => \%tmp };
74             }
75              
76             sub pollack
77             {
78 0     0 0   my ($epp,$msgid)=@_;
79 0           my $mes=$epp->message();
80 0 0         Net::DRI::Exception::usererr_invalid_parameters('In EPP, you must specify the message id (XML token) you want to delete') unless Net::DRI::Util::xml_is_token($msgid);
81 0           $mes->command([['poll',{op=>'ack',msgID=>$msgid}]]);
82 0           return;
83             }
84              
85             sub pollreq
86             {
87 0     0 0   my ($epp,$msgid)=@_;
88 0 0         Net::DRI::Exception::usererr_invalid_parameters('In EPP, you can not specify the message id you want to retrieve') if defined($msgid);
89 0           my $mes=$epp->message();
90 0           $mes->command([['poll',{op=>'req'}]]);
91 0           return;
92             }
93              
94             ## elements in @prio come out first, in the same order as given (but only those existing in %$rh), then other keys of %$rh are reordered
95             sub _sort
96             {
97 0     0     my ($rh, @prio) = @_;
98 0           @prio = grep { exists $rh->{$_} } @prio;
  0            
99 0           my %prio = map { $_ => 1 } @prio;
  0            
100 0           return (@prio, sort { $a cmp $b } grep { ! exists $prio{$_} } keys %$rh);
  0            
  0            
101             }
102              
103             ## We take into account all parse functions, to be able to parse any result
104             sub parse_poll
105             {
106 0     0 0   my ($po,$otype,$oaction,$oname,$rinfo)=@_;
107 0 0         return if exists $rinfo->{_processing_parse_poll}; ## calling myself here would be a very bad idea !
108 0           my $mes=$po->message();
109 0 0         return unless $mes->is_success();
110              
111 0           my $msgid=$mes->msg_id();
112 0 0 0       return unless (defined($msgid) && $msgid);
113 0           $rinfo->{message}->{session}->{last_id}=$msgid; ## needed here and not lower below, in case of pure text registry message
114              
115             ## Was there really a registry message with some content ?
116 0 0 0       return unless ($mes->result_code() == 1301 && (defined($mes->node_resdata()) || defined($mes->node_extension()) || defined($mes->node_msg())));
      0        
117              
118 0           my $rd=$rinfo->{message}->{$msgid}; ## already partially filled by Message::parse()
119 0           my ($totype,$toaction,$toname); ## $toaction will remain undef, but could be $haction if only one
120 0           my %info;
121 0           my $h=$po->commands();
122              
123             ## Because of Perl hash keys randomization, we must make sure to order types first, prefering core objects,
124             ## and then order actions, to make sure review_complete is done first (as it will setup $toname & such)
125 0           foreach my $htype (_sort($h, qw/domain contact host/))
126             {
127 0           my $hv=$h->{$htype};
128 0           foreach my $haction (_sort($hv, 'review_complete'))
129             {
130 0 0 0       next if $htype eq 'message' && $haction eq 'result';
131 0           foreach my $t (@{$hv->{$haction}})
  0            
132             {
133 0           my $pf=$t->[1];
134 0 0 0       next unless (defined($pf) && (ref($pf) eq 'CODE'));
135 0           $info{_processing_parse_poll}=1;
136 0           $pf->($po,$totype,$toaction,$toname,\%info);
137 0           delete $info{_processing_parse_poll};
138 0           my @tmp=grep { $_ ne '_internal' } keys %info;
  0            
139 0 0         next unless @tmp;
140 0 0         next if defined $toname; ## this must be there and not optimised as a last call further below as there can be multiple information to parse for a given $toname
141 0 0         Net::DRI::Exception::err_assert('EPP::parse_poll can not handle multiple types !') unless @tmp==1;
142 0           $totype=$tmp[0];
143 0           @tmp=keys %{$info{$totype}};
  0            
144 0 0         Net::DRI::Exception::err_assert('EPP::parse_poll can not handle multiple names !') unless @tmp==1; ## this may happen for check_multi !
145 0           $toname=$tmp[0];
146 0           $info{$totype}->{$toname}->{name}=$toname;
147             }
148             }
149             }
150              
151             ## If message not completely in the node, we have to parse something !
152 0 0 0       Net::DRI::Exception::err_assert('EPP::parse_poll was not able to parse anything, please report !') if ((defined($mes->node_resdata()) || defined($mes->node_extension())) && ! defined $toname);
      0        
153              
154             ## Copy local %info into $rd (which is in fact global info as set above) someway (we're working with references)
155             ## Here, $rd=$rinfo->{message}->{$msgid}
156 0           $rd->{object_type}=$totype;
157 0           $rd->{object_id}=$toname; ## this has to be taken broadly, it is in fact a name for domains and hosts
158 0           while(my ($k,$v)=each(%{$info{$totype}->{$toname}}))
  0            
159             {
160 0           $rd->{$k}=$v;
161             }
162 0 0         if (exists $info{message}->{$msgid})
163             {
164 0           while(my ($k,$v)=each(%{$info{message}->{$msgid}}))
  0            
165             {
166 0           $rd->{$k}=$v;
167             }
168             }
169             ## Also update data about the queried object, for easier access
170 0           while(my ($k,$v)=each(%$rd))
171             {
172 0           $rinfo->{$totype}->{$toname}->{$k}=$v;
173             }
174 0           return;
175             }
176              
177             ####################################################################################################
178             1;