File Coverage

blib/lib/Net/DRI/Protocol.pm
Criterion Covered Total %
statement 145 184 78.8
branch 29 70 41.4
condition 30 90 33.3
subroutine 27 38 71.0
pod 1 13 7.6
total 232 395 58.7


line stmt bran cond sub pod time code
1             ## Domain Registry Interface, Protocol superclass
2             ##
3             ## Copyright (c) 2005-2011,2013-2014,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;
16              
17 68     68   2145 use strict;
  68         75  
  68         1490  
18 68     68   193 use warnings;
  68         654  
  68         1416  
19              
20 68     68   199 use base qw(Class::Accessor::Chained::Fast Net::DRI::BaseClass);
  68         97  
  68         6436  
21             __PACKAGE__->mk_accessors(qw(name version commands message default_parameters logging));
22              
23 68     68   1918 use DateTime;
  68         158305  
  68         1063  
24 68     68   221 use DateTime::Duration;
  68         79  
  68         1057  
25 68     68   32613 use DateTime::Format::ISO8601;
  68         2869692  
  68         2793  
26 68     68   488 use DateTime::Format::Strptime;
  68         81  
  68         314  
27              
28 68     68   3118 use Net::DRI::Exception;
  68         90  
  68         1214  
29 68     68   649 use Net::DRI::Util;
  68         86  
  68         1177  
30 68     68   32050 use Net::DRI::Data::Changes;
  68         121  
  68         1698  
31 68     68   24602 use Net::DRI::Data::Contact;
  68         152  
  68         485  
32 68     68   33501 use Net::DRI::Data::ContactSet;
  68         128  
  68         1639  
33 68     68   28048 use Net::DRI::Data::Hosts;
  68         137  
  68         312  
34 68     68   29398 use Net::DRI::Data::StatusList;
  68         121  
  68         1622  
35 68     68   28436 use Net::DRI::Data::LanguageTag;
  68         110  
  68         93301  
36              
37             =pod
38              
39             =head1 NAME
40              
41             Net::DRI::Protocol - Superclass of all Net::DRI Protocols
42              
43             =head1 DESCRIPTION
44              
45             Please see the README file for details.
46              
47             =head1 SUPPORT
48              
49             For now, support questions should be sent to:
50              
51             Enetdri@dotandco.comE
52              
53             Please also see the SUPPORT file in the distribution.
54              
55             =head1 SEE ALSO
56              
57             Ehttp://www.dotandco.com/services/software/Net-DRI/E
58              
59             =head1 AUTHOR
60              
61             Patrick Mevzek, Enetdri@dotandco.comE
62              
63             =head1 COPYRIGHT
64              
65             Copyright (c) 2005-2011,2013-2014,2016 Patrick Mevzek .
66             All rights reserved.
67              
68             This program is free software; you can redistribute it and/or modify
69             it under the terms of the GNU General Public License as published by
70             the Free Software Foundation; either version 2 of the License, or
71             (at your option) any later version.
72              
73             See the LICENSE file that comes with this distribution for more details.
74              
75             =cut
76              
77             ####################################################################################################
78              
79             sub new
80             {
81 2     2 1 13 my ($class,$ctx)=@_;
82              
83             my $self={ capabilities=> {},
84 0     0   0 factories => { datetime => sub { return DateTime->new(@_); },
85 0     0   0 duration => sub { return DateTime::Duration->new(@_); },
86 3     3   14 changes => sub { return Net::DRI::Data::Changes->new(@_); },
87 0     0   0 contact => sub { return Net::DRI::Data::Contact->new(); },
88 0     0   0 contactset => sub { return Net::DRI::Data::ContactSet->new(@_); },
89 8     8   25 hosts => sub { return Net::DRI::Data::Hosts->new(@_); },
90 0     0   0 status => sub { return Net::DRI::Data::StatusList->new(@_); },
91 0     0   0 language_tag=> sub { return Net::DRI::Data::LanguageTag->new(@_); },
92             },
93             logging => $ctx->{registry}->logging(),
94             logging_ctx => { registry => $ctx->{registry}->name(), profile => $ctx->{profile}, transport_class => $ctx->{transport_class} },
95 2         42 };
96              
97 2         14 bless($self,$class);
98 2         9 $self->message(undef);
99 2         34 $self->default_parameters({});
100              
101 2         18 $self->log_setup_channel($class,'protocol',$self->{logging_ctx});
102 2         7 $self->log_output('debug','core',sprintf('Added profile %s for registry %s',$class,$ctx->{registry}->name()));
103 2         4 return $self;
104             }
105              
106             sub log_output
107             {
108 5     5 0 19 my ($self,$level,$type,$data1)=@_;
109 5 100 100     18 $self->{logging_ctx}->{protocol}=$self->name().'/'.$self->version() if (! exists $self->{logging_ctx}->{protocol} && defined $self->name());
110 5 50       32 return $self->logging()->output($level,$type,ref $data1 ? +{ %{$self->{logging_ctx}}, %$data1 } : $data1);
  0         0  
111             }
112              
113              
114             sub parse_iso8601
115             {
116 0     0 0 0 my ($self,$d)=@_;
117 0 0       0 $self->{iso8601_parser}=DateTime::Format::ISO8601->new() unless exists $self->{iso8601_parser};
118 0         0 return $self->{iso8601_parser}->parse_datetime($d);
119             }
120              
121             sub build_strptime_parser
122             {
123 0     0 0 0 my ($self,@args)=@_;
124 0         0 my $key=join("\x{001E}",@args);
125 0 0       0 $self->{strptime_parser}->{$key}=DateTime::Format::Strptime->new(@args) unless exists $self->{strptime_parser}->{$key};
126 0         0 return $self->{strptime_parser}->{$key};
127             }
128              
129             sub create_local_object
130             {
131 31     31 0 35 my ($self,$what,@args)=@_;
132 31 50 33     91 return unless defined $self && defined $what;
133 31         42 my $fn=$self->factories();
134 31 50 33     193 Net::DRI::Exception::err_assert('invalid factory name "'.$what.'"') unless defined $fn && ref $fn eq 'HASH' && exists $fn->{$what} && ref $fn->{$what} eq 'CODE';
      33        
      33        
135 31         60 return $fn->{$what}->(@args);
136             }
137              
138             ## This should not be called multiple times for a given Protocol class (as it will erase the loaded_modules slot)
139             sub _load
140             {
141 1     1   1 my ($self,@classes)=@_;
142 1         4 my $etype='protocol/'.$self->name();
143 1         7 my $version=$self->version();
144              
145 1         4 my %skip = map { substr($_,1) => 1 } grep { /^-/ } @classes;
  0         0  
  3         5  
146              
147 1         1 my (%c,%done,@done);
148 1         2 foreach my $class (@classes)
149             {
150 3 50 33     18 next if exists $done{$class} || $class=~m/^-/ || exists $skip{$class};
      33        
151 3         13 $self->log_output('debug','core',sprintf('Loading class "%s"',$class));
152 3         10 Net::DRI::Util::load_module($class,$etype);
153 3 50       34 Net::DRI::Exception::method_not_implemented('register_commands',$class) unless $class->can('register_commands');
154 3         8 my $rh=$class->register_commands($version);
155 3         5 $self->{commands_by_class}->{$class}=$rh;
156 3         21 Net::DRI::Util::hash_merge(\%c,$rh); ## { object type => { action type => [ build action, parse action ]+ } }
157 3 50       19 if ($class->can('capabilities_add'))
158             {
159 0         0 my @a=$class->capabilities_add();
160 0 0       0 if (ref($a[0]))
161             {
162 0         0 foreach my $a (@a) { $self->capabilities(@$a); }
  0         0  
163             } else
164             {
165 0         0 $self->capabilities(@a);
166             }
167             }
168 3 50       13 $class->setup($self,$version) if $class->can('setup');
169 3         4 $done{$class}=1;
170 3         5 push @done,$class;
171             }
172              
173 1         2 $self->{loaded_modules}=\@done;
174 1         6 $self->commands(\%c);
175 1         9 return;
176             }
177              
178             ## has_module + find_action_in_class should instead better be based on some ID, like the XML namespace in EPP,
179             ## instead of the Perl module names
180             sub has_module
181             {
182 0     0 0 0 my ($self,$mod)=@_;
183 0 0 0     0 return 0 unless defined $mod && length $mod;
184 0 0       0 return (grep { $_ eq $mod } @{$self->{loaded_modules}})? 1 : 0;
  0         0  
  0         0  
185             }
186              
187             sub find_action_in_class
188             {
189 0     0 0 0 my ($self,$class,$otype,$oaction)=@_;
190 0 0 0     0 return unless defined $class && length $class && exists $self->{commands_by_class}->{$class} && exists $self->{commands_by_class}->{$class}->{$otype} && exists $self->{commands_by_class}->{$class}->{$otype}->{$oaction};
      0        
      0        
      0        
191 0 0       0 return wantarray ? @{$self->{commands_by_class}->{$class}->{$otype}->{$oaction}} : $self->{commands_by_class}->{$class}->{$otype}->{$oaction}->[0];
  0         0  
192             }
193              
194             sub _load_commands
195             {
196 20     20   21 my ($self,$otype,$oaction)=@_;
197              
198 20         39 my $etype='protocol/'.$self->name();
199 20 50 33     185 Net::DRI::Exception->die(1,$etype,7,'Object type and/or action not defined') unless (defined $otype && length $otype && defined $oaction && length $oaction);
      33        
      33        
200 20         27 my $h=$self->commands();
201 20 50       74 Net::DRI::Exception->die(1,$etype,8,'No actions defined for object of type <'.$otype.'>') unless exists($h->{$otype});
202 20 50       31 Net::DRI::Exception->die(1,$etype,9,'No action name <'.$oaction.'> defined for object of type <'.$otype.'> in '.ref($self)) unless exists($h->{$otype}->{$oaction});
203 20         20 return $h;
204             }
205              
206             sub has_action
207             {
208 0     0 0 0 my ($self,$otype,$oaction)=@_;
209 0 0       0 return eval { my $h=$self->_load_commands($otype,$oaction); 1; } ? 1 : 0;
  0         0  
  0         0  
210             }
211              
212             sub action
213             {
214 10     10 0 13 my ($self,$otype,$oaction,$trid,@params)=@_;
215 10         29 my $h=$self->_load_commands($otype,$oaction);
216              
217             ## Create a new message from scratch and loop through all functions registered for given action & type
218 10         15 my $msg=$self->create_local_object('message',$trid,$otype,$oaction);
219 10 50 33     85 Net::DRI::Exception->die(0,'protocol',1,'Unsuccessfull message creation') unless ($msg && ref $msg && $msg->isa('Net::DRI::Protocol::Message'));
      33        
220 10         18 $self->message($msg); ## store it for later use (in loop below)
221              
222 10         34 foreach my $t (@{$h->{$otype}->{$oaction}})
  10         19  
223             {
224 10         11 my $pf=$t->[0];
225 10 50 33     31 next unless (defined($pf) && (ref($pf) eq 'CODE'));
226 10         48 $pf->($self,@params);
227             }
228              
229 10         22 $self->message(undef); ## needed ? useful ?
230 10         56 return $msg;
231             }
232              
233             sub reaction
234             {
235 10     10 0 11 my ($self,$otype,$oaction,$dr,$sent,$oname,$trid)=@_;
236 10         13 my $h=$self->_load_commands($otype,$oaction);
237 10         17 my $msg=$self->create_local_object('message');
238 10 50 33     56 Net::DRI::Exception->die(0,'protocol',1,'Unsuccessfull message creation') unless ($msg && ref($msg) && $msg->isa('Net::DRI::Protocol::Message'));
      33        
239              
240 10         8 my %info;
241             ## TODO is $sent needed here really ? if not remove from API above also !
242 10         23 $msg->parse($dr,\%info,$otype,$oaction,$sent); ## will trigger an Exception by itself if problem ## TODO : add later the whole LocalStorage stuff done when sending ? (instead of otype/oaction/message sent)
243 10         21 $self->message($msg); ## store it for later use (in loop below)
244 10 0 66     66 $info{$otype}->{$oname}->{name}=$oname if ($otype eq 'domain' || $otype eq 'host' || $otype eq 'nsgroup' || $otype eq 'keygroup'); ## TODO : abstract this ?
      33        
      33        
245              
246 10 0 33     17 if (exists $h->{message} && exists $h->{message}->{result})
247             {
248 0         0 foreach my $t (@{$h->{message}->{result}})
  0         0  
249             {
250 0         0 my $pf=$t->[1];
251 0 0 0     0 next unless (defined $pf && ref $pf eq 'CODE');
252 0         0 $pf->($self,$otype,$oaction,$oname,\%info);
253             }
254             }
255              
256 10         9 foreach my $t (@{$h->{$otype}->{$oaction}})
  10         18  
257             {
258 10         30 my $pf=$t->[1];
259 10 100 66     34 next unless (defined $pf && ref $pf eq 'CODE');
260 6         17 $pf->($self,$otype,$oaction,$oname,\%info);
261             }
262              
263 10         22 my $rc=$msg->result_status();
264 10 50       21 if (defined $rc)
265             {
266 10 50       21 $rc->_set_trid([ $trid ]) unless $rc->trid(); ## if not done inside Protocol::*::Message::result_status, make sure we save at least our transaction id
267 10         19 foreach my $v1 (values %info)
268             {
269 10 50 33     38 next unless ref $v1 eq 'HASH' && keys %$v1;
270 10         7 foreach my $v2 (values %{$v1})
  10         14  
271             {
272 10 50 33     39 next unless ref $v2 eq 'HASH' && keys %$v2; ## yes, this can happen, with must_reconnect for example
273 10 50       13 next if exists $v2->{result_status};
274 10         20 $v2->{result_status}=$rc;
275             }
276             }
277             }
278 10         20 $self->message(undef); ## needed ? useful ?
279              
280 10         51 $info{session}->{exchange}->{result_from_cache}=0;
281 10         18 $info{session}->{exchange}->{protocol}=$self->nameversion();
282 10         63 $info{session}->{exchange}->{trid}=$trid;
283 10         47 return ($rc,\%info);
284             }
285              
286             sub nameversion
287             {
288 14     14 0 737 my $self=shift;
289 14         27 return $self->name().'/'.$self->version();
290             }
291              
292             sub factories
293             {
294 33     33 0 25 my ($self,$object,$code)=@_;
295 33 100 66     53 if (defined $object && defined $code)
296             {
297 2         3 $self->{factories}->{$object}=$code;
298 2         3 return $self;
299             }
300 31         34 return $self->{factories};
301             }
302              
303             sub capabilities
304             {
305 12     12 0 896 my ($self,$action,$object,$cap)=@_;
306 12 100 66     30 if (defined($action) && defined($object))
307             {
308 4 100       10 $self->{capabilities}->{$action}={} unless exists($self->{capabilities}->{$action});
309 4 50       5 if (defined($cap))
310             {
311 4         5 $self->{capabilities}->{$action}->{$object}=$cap;
312             } else
313             {
314 0         0 delete($self->{capabilities}->{$action}->{$object});
315             }
316             }
317 12         21 return $self->{capabilities};
318             }
319              
320             ####################################################################################################
321             1;