File Coverage

blib/lib/Net/DRI/Registry.pm
Criterion Covered Total %
statement 245 367 66.7
branch 77 198 38.8
condition 43 138 31.1
subroutine 38 56 67.8
pod 1 43 2.3
total 404 802 50.3


line stmt bran cond sub pod time code
1             ## Domain Registry Interface, Registry object
2             ##
3             ## Copyright (c) 2005-2011,2013-2015 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::Registry;
16              
17 75     75   272 use strict;
  75         87  
  75         1815  
18 75     75   245 use warnings;
  75         77  
  75         1891  
19              
20 75     75   214 use base qw(Class::Accessor::Chained::Fast Net::DRI::BaseClass);
  75         71  
  75         26263  
21             __PACKAGE__->mk_ro_accessors(qw(name driver profile trid_factory logging)); ## READ-ONLY !!
22              
23 75     75   297 use Time::HiRes ();
  75         101  
  75         891  
24              
25 75     75   202 use Net::DRI::Exception;
  75         68  
  75         849  
26 75     75   193 use Net::DRI::Util;
  75         66  
  75         962  
27 75     75   27209 use Net::DRI::Protocol::ResultStatus;
  75         111  
  75         306  
28 75     75   26438 use Net::DRI::Data::RegistryObject;
  75         108  
  75         235282  
29              
30             our $AUTOLOAD;
31              
32             =pod
33              
34             =head1 NAME
35              
36             Net::DRI::Registry - Specific Registry Driver Instance inside Net::DRI
37              
38             =head1 DESCRIPTION
39              
40             Please see the README file for details.
41              
42             =head1 SUPPORT
43              
44             For now, support questions should be sent to:
45              
46             Enetdri@dotandco.comE
47              
48             Please also see the SUPPORT file in the distribution.
49              
50             =head1 SEE ALSO
51              
52             Ehttp://www.dotandco.com/services/software/Net-DRI/E
53              
54             =head1 AUTHOR
55              
56             Patrick Mevzek, Enetdri@dotandco.comE
57              
58             =head1 COPYRIGHT
59              
60             Copyright (c) 2005-2011,2013-2015 Patrick Mevzek .
61             All rights reserved.
62              
63             This program is free software; you can redistribute it and/or modify
64             it under the terms of the GNU General Public License as published by
65             the Free Software Foundation; either version 2 of the License, or
66             (at your option) any later version.
67              
68             See the LICENSE file that comes with this distribution for more details.
69              
70             =cut
71              
72             ####################################################################################################
73              
74             sub new
75             {
76 66     66 1 153 my ($class,$name,$drd,$cache,$trid,$logging)=@_;
77              
78 66         582 my $self={name => $name,
79             driver => $drd,
80             cache => $cache,
81             profiles => {}, ## { profile name => { protocol => X
82             ## transport => X
83             ## status => Net::DRI::Protocol::ResultStatus
84             ## %extra
85             ## }
86             ## }
87             profile => undef, ## current profile
88             auto_target => {},
89             last_data => {},
90             last_process => {},
91             trid_factory => $trid,
92             logging => $logging,
93             };
94              
95 66         155 bless($self,$class);
96 66         228 return $self;
97             }
98              
99             sub available_profile
100             {
101 0     0 0 0 my $self=shift;
102 0 0       0 return (defined($self->{profile}))? 1 : 0;
103             }
104              
105             sub available_profiles
106             {
107 0     0 0 0 my ($self,$full)=@_;
108 0   0     0 $full||=0;
109 0 0       0 my @r=sort { $a cmp $b } ($full ? map { $_->{fullname} } values(%{$self->{profiles}}) : keys(%{$self->{profiles}}));
  0         0  
  0         0  
  0         0  
  0         0  
110 0         0 return @r;
111             }
112              
113             sub exist_profile
114             {
115 66     66 0 125 my ($self,$name)=@_;
116 66   33     673 return (defined($name) && exists($self->{profiles}->{$name}));
117             }
118              
119 4     4 0 15 sub err_no_current_profile { Net::DRI::Exception->die(0,'DRI',3,'No current profile available'); } ## no critic (Subroutines::RequireArgUnpacking Subroutines::RequireFinalReturn)
120 0     0 0 0 sub err_profile_name_does_not_exist { Net::DRI::Exception->die(0,'DRI',4,'Profile name '.$_[0].' does not exist'); } ## no critic (Subroutines::RequireArgUnpacking Subroutines::RequireFinalReturn)
121              
122             sub remote_object
123             {
124 0     0 0 0 my ($self,@args)=@_;
125 0         0 return Net::DRI::Data::RegistryObject->new($self,@args);
126             }
127              
128             sub _current
129             {
130 55     55   51 my ($self,$what,$tostore)=@_;
131 55 100       88 err_no_current_profile() unless (defined($self->{profile}));
132 51 50       72 err_profile_name_does_not_exist($self->{profile}) unless (exists($self->{profiles}->{$self->{profile}}));
133 51 50 33     131 Net::DRI::Exception::err_assert('key should be transport, protocol or status, and not: '.$what) unless defined $what && exists $self->{profiles}->{$self->{profile}}->{$what};
134              
135 51 100 66     98 if (($what eq 'status') && $tostore)
136             {
137 10         17 $self->{profiles}->{$self->{profile}}->{$what}=$tostore;
138             }
139              
140 51         102 return $self->{profiles}->{$self->{profile}}->{$what};
141             }
142              
143 10     10 0 12 sub transport { return shift->_current('transport'); }
144 21     21 0 31 sub protocol { return shift->_current('protocol'); }
145 10     10 0 19 sub status { return shift->_current('status',@_); } ## no critic (Subroutines::RequireArgUnpacking)
146 11     11 0 9 sub protocol_transport { my $self=shift; return ($self->protocol(),$self->transport()); }
  11         17  
147              
148             sub local_object
149             {
150 14     14 0 18 my ($self,$f,@args)=@_;
151 14 50 33     53 return unless $self && $f;
152 14         29 return $self->_current('protocol')->create_local_object($f,@args);
153             }
154              
155             sub _result
156             {
157 3     3   4 my ($self,$f)=@_;
158 3         7 my $p=$self->profile();
159 3 50       11 err_no_current_profile() unless (defined($p));
160 3 50       7 Net::DRI::Exception->die(0,'DRI',6,'No last status code available for current registry and profile') unless (exists($self->{profiles}->{$p}->{status}));
161 3         4 my $rc=$self->{profiles}->{$p}->{status}; ## a Net::DRI::Protocol::ResultStatus object !
162 3 50       6 Net::DRI::Exception->die(1,'DRI',5,'Status key is not a Net::DRI::Protocol::ResultStatus object') unless Net::DRI::Util::is_class($rc,'Net::DRI::Protocol::ResultStatus');
163 3 50       6 return $rc if ($f eq 'self');
164 3 50 33     16 Net::DRI::Exception::method_not_implemented($f,'Net::DRI::Protocol::ResultStatus') unless ($f && $rc->can($f));
165 3         8 return $rc->$f();
166             }
167              
168 1     1 0 4 sub result_is_success { return shift->_result('is_success'); }
169 0     0 0 0 sub is_success { return shift->_result('is_success'); } ## Alias
170 1     1 0 4 sub result_code { return shift->_result('code'); }
171 1     1 0 4 sub result_native_code { return shift->_result('native_code'); }
172 0     0 0 0 sub result_message { return shift->_result('message'); }
173 0     0 0 0 sub result_lang { return shift->_result('lang'); }
174 0     0 0 0 sub result_status { return shift->_result('self'); }
175 0     0 0 0 sub result_extra_info { return shift->_result('info'); }
176              
177 0     0 0 0 sub cache_expire { return shift->{cache}->delete_expired(); }
178 0     0 0 0 sub cache_clear { return shift->{cache}->delete(); }
179              
180             sub set_info
181             {
182 20     20 0 25 my ($self,$type,$key,$data,$ttl)=@_;
183 20         38 my $p=$self->profile();
184 20 50       66 err_no_current_profile() unless defined($p);
185 20         29 my $regname=$self->name();
186              
187 20         91 my $c=$self->{cache}->set($regname.'.'.$p,$type,$key,$data,$ttl);
188 20         23 $self->{last_data}=$c; ## the hash exists, since we called clear_info somewhere before
189 20         36 $self->{last_data}->{result_from_cache}=0;
190              
191 20         28 return $c;
192             }
193              
194             ## Returns a $rc object or undef if nothing found in cache for the specific object ($type/$key) and action ($action)
195             sub try_restore_from_cache
196             {
197 5     5 0 7 my ($self,$type,$key,$action)=@_;
198 5 50       8 if (! Net::DRI::Util::all_valid($type,$key,$action)) { Net::DRI::Exception::err_assert('try_restore_from_cache improperly called'); }
  0         0  
199              
200 5         9 my $a=$self->get_info('action',$type,$key);
201             ## not in cache or in cache but for some other action
202 5 50 33     12 if (! defined $a || ($a ne $action)) { $self->log_output('debug','core',sprintf('Cache MISS (empty cache or other action) for type=%s key=%s',$type,$key)); return; }
  5         16  
  5         9  
203              
204             ## retrieve from cache, copy, and do some cleanup
205 0         0 $self->{last_data}=$self->get_info_all($type,$key);
206             ## since we passed the above test on get_info('action'), we know here we received something defined by get_info_all,
207             ## but we test explicitly again (get_info_all returns an empty ref hash on problem, not undef), to avoid race conditions and such
208 0 0       0 if (! keys(%{$self->{last_data}})) { $self->log_output('debug','core',sprintf('Cache MISS (no last_data content) for type=%s key=%s',$type,$key)); return; }
  0         0  
  0         0  
  0         0  
209              
210             ## Clone the result_status object as it may be linked from others part, and we may tweak its link chain (for example in domain_check)
211 0         0 $self->{last_data}->{result_status}=$self->{last_data}->{result_status}->clone();
212              
213             ## get_info_all makes a copy, but only at first level ! so this high level change is ok (no pollution), but be warned for below !
214 0         0 $self->{last_data}->{result_from_cache}=1;
215              
216             ## Important note here:
217             ## we were previously kind of copying the session/exchange branch as obtained from $self->{last_data}->{result_status}->{local,global}_get_data_collection()
218             ## before doing change
219             ## however this is in fact unnecessary and complicated
220             ## complicated because in fact of the ambiguity above in local or global get_data_collection
221             ## unneccessary because wer are just setting result_from_cache to 1 here in session/exchange,
222             ## and 1) as soon as this flag is flipped, it will never revert back to 0
223             ## 2) in process_back() below we made a copy of session/exchange before putting it in ResultStatus, so changing it here, does not change previous result status given back to client
224 0         0 $self->{last_data}->{result_status}->local_get_data_collection()->{session}->{exchange}->{result_from_cache}=1;
225 0         0 $self->{cache}->set_result_from_cache($type,$key);
226 0         0 $self->{cache}->set_result_from_cache('session','exchange');
227 0         0 $self->{cache}->set_result_from_cache('message','info');
228              
229 0         0 $self->log_output('debug','core',sprintf('Cache HIT for type=%s key=%s',$type,$key));
230 0         0 return $self->{last_data}->{result_status};
231             }
232              
233 10     10 0 16 sub clear_info { shift->{last_data}={}; } ## no critic (Subroutines::RequireFinalReturn)
234              
235             sub get_info
236             {
237 28     28 0 33 my ($self,$what,$type,$key)=@_;
238 28 50 33     85 return unless defined $what && $what;
239              
240 28 100       52 if (Net::DRI::Util::all_valid($type,$key)) ## search the cache, by default same registry & profile !
241             {
242 5         11 my $p=$self->profile();
243 5 50       20 err_no_current_profile() unless defined($p);
244 5         9 my $regname=$self->name();
245 5         23 return $self->{cache}->get($type,$key,$what,$regname.'.'.$p);
246             } else
247             {
248 23 50       46 return unless exists $self->{last_data}->{$what};
249 23         59 return $self->{last_data}->{$what};
250             }
251             }
252              
253             sub get_info_all
254             {
255 0     0 0 0 my ($self,$type,$key)=@_;
256 0         0 my $rh;
257              
258 0 0       0 if (Net::DRI::Util::all_valid($type,$key))
259             {
260 0         0 my $p=$self->profile();
261 0 0       0 err_no_current_profile() unless defined($p);
262 0         0 my $regname=$self->name();
263 0         0 $rh=$self->{cache}->get($type,$key,undef,$regname.'.'.$p);
264             } else
265             {
266 0         0 $rh=$self->{last_data};
267             }
268              
269 0 0 0     0 return {} unless (defined($rh) && ref($rh) && keys(%$rh));
      0        
270              
271 0         0 my %h=%{ $rh }; ## create a copy, as we will delete content... ## BUGFIX !!
  0         0  
272 0         0 foreach my $k (grep { /^_/ } keys(%h)) { delete($h{$k}); }
  0         0  
  0         0  
273 0         0 return \%h;
274             }
275              
276             sub get_info_keys
277             {
278 0     0 0 0 my ($self,$type,$key)=@_;
279 0         0 my @r=sort { $a cmp $b } keys %{ $self->get_info_all($type,$key) };
  0         0  
  0         0  
280 0         0 return @r;
281             }
282              
283             ####################################################################################################
284             ## Change profile
285             sub target
286             {
287 1     1 0 3 my ($self,$profile)=@_;
288 1 50 33     6 err_profile_name_does_not_exist($profile) unless ($profile && exists($self->{profiles}->{$profile}));
289 1         3 $self->{profile}=$profile;
290 1         2 return;
291             }
292              
293             sub profile_auto_switch
294             {
295 11     11 0 13 my ($self,$otype,$oaction)=@_;
296 11         20 my $p=$self->get_auto_target($otype,$oaction);
297 11 50       19 return unless defined($p);
298 0         0 $self->target($p);
299 0         0 return;
300             }
301              
302             sub set_auto_target
303             {
304 0     0 0 0 my ($self,$profile,$otype,$oaction)=@_; ## $otype/$oaction may be undef
305 0 0 0     0 err_profile_name_does_not_exist($profile) unless ($profile && exists($self->{profiles}->{$profile}));
306              
307 0         0 my $rh=$self->{auto_target};
308 0   0     0 $otype||='_default';
309 0   0     0 $oaction||='_default';
310 0 0       0 $rh->{$otype}={} unless (exists($rh->{$otype}));
311 0         0 $rh->{$otype}->{$oaction}=$profile;
312 0         0 return;
313             }
314              
315             sub get_auto_target
316             {
317 11     11 0 10 my ($self,$otype,$oaction)=@_;
318 11         11 my $at=$self->{auto_target};
319 11 50       19 $otype='_default' unless (exists($at->{$otype}));
320 11 50       27 return unless (exists($at->{$otype}));
321 0         0 my $ac=$at->{$otype};
322 0 0 0     0 return unless (defined($ac) && ref($ac));
323 0 0       0 $oaction='_default' unless (exists($ac->{$oaction}));
324 0 0       0 return unless (exists($ac->{$oaction}));
325 0         0 return $ac->{$oaction};
326             }
327              
328             sub add_current_profile
329             {
330 66     66 0 163 my ($self,@p)=@_;
331 66         274 my $rc=$self->add_profile(@p);
332 1 50       5 $self->target($p[0]) if $rc->is_success();
333 1         7 return $rc;
334             }
335              
336             ## Transport and Protocol parameters are merged (semantically but not chronologically, parameters coming later erase previous ones) in this order;
337             ## - TransportConnectionClass->transport_default() [only for transport parameters]
338             ## - Protocol->transport_default() [only for transport parameters]
339             ## - DRD->transport_protocol_default()
340             ## - user specified parameters to add_profile (they always have precedence over defaults stored in the 3 previous cases)
341              
342             ## API: profile name, profile type, transport params {}, protocol params {}
343             sub add_profile
344             {
345 66     66 0 117 my ($self,$name,$type,$trans_p,$prot_p)=@_;
346              
347 66 50       271 if (! Net::DRI::Util::all_valid($name,$type)) { Net::DRI::Exception::usererr_insufficient_parameters('add_profile needs at least 2 parameters: new profile name and type'); }
  0         0  
348 66 50       494 if ($self->exist_profile($name)) { Net::DRI::Exception::usererr_invalid_parameters('New profile name "'.$name.'" already in use'); }
  0         0  
349 66 50 33     459 if (defined $trans_p && ref $trans_p ne 'HASH') { Net::DRI::Exception::usererr_invalid_parameters('If provided, 3rd parameter of add_profile (transport data) must be a ref hash'); }
  0         0  
350 66 50 66     382 if (defined $prot_p && ref $prot_p ne 'HASH') { Net::DRI::Exception::usererr_invalid_parameters('If provided, 4th parameter of add_profile (protocol data) must be a ref hash'); }
  0         0  
351              
352 66         340 my $drd=$self->driver();
353 66         405 my ($tc,$tp,$pc,$pp)=$drd->transport_protocol_default($type); ## Transport Class, Transport Params, Protocol Class, Protocol Params
354 66         153 my $test=0;
355 66 50 33     588 if (exists $INC{'Test/More.pm'} && defined $trans_p && exists $trans_p->{f_send})
      33        
356             {
357 66         124 $test=1;
358 66         405 $self->log_output('emergency','core','For profile "'.$name.'", using INTERNAL TESTING configuration! This should not happen in production, but only during "make test"!');
359 66         214 $tc='Net::DRI::Transport::Dummy';
360 66         1678 $tp={};
361             }
362              
363 66 50 33     400 if (!Net::DRI::Util::all_valid($tc,$tp,$pc,$pp) || ref $tp ne 'HASH' || ref $pp ne 'HASH') { Net::DRI::Exception::usererr_invalid_parameters(sprintf('Registry "%s" does not provide profile type "%s")',$self->name(),$type)); }
  0   33     0  
364              
365 66 50       366 $tp={ %$tp, %$trans_p } if defined $trans_p;
366 66 100       255 $pp={ %$pp, %$prot_p } if defined $prot_p;
367              
368 66 100       478 $drd->transport_protocol_init($type,$tc,$tp,$pc,$pp,$test) if $drd->can('transport_protocol_init');
369              
370 66         261 Net::DRI::Util::load_module($tc,'DRI');
371 66         182 Net::DRI::Util::load_module($pc,'DRI');
372 1         10 $self->log_output('debug','core',sprintf('For profile "%s" attempting to initialize transport "%s" and protocol "%s"',$name,$tc,$pc));
373              
374             ## Protocol must come first, as it may be needed during transport setup; it should not die
375 1         8 my $po=$pc->new({registry=>$self,profile=>$name,transport_class=>$tc},$pp);
376 1 50       15 $tp={ $po->transport_default(), %$tp } if ($po->can('transport_default'));
377              
378 1         2 my ($to,$rc);
379             my $ok=eval
380 1         2 {
381 1         9 ($to,$rc)=$tc->new({registry=>$self,profile=>$name,protocol=>$po},$tp); ## this may die !
382 1         3 1;
383             };
384 1 50       3 if (! $ok) ## some kind of error happened
385             {
386 0         0 my $err=$@;
387 0 0       0 return $err if ref $err eq 'Net::DRI::Protocol::ResultStatus';
388 0 0       0 $err=Net::DRI::Exception->new(1,'internal',0,'Error not handled: '.$err) unless ref $err;
389 0         0 die $err;
390             }
391 1 50 33     10 return $rc if defined $rc && ! $rc->is_success();
392              
393 1         2 my $fullname=sprintf('%s (%s/%s + %s/%s)',$name,$po->name(),$po->version(),$to->name(),$to->version());
394 1         15 $self->{profiles}->{$name}={ fullname => $fullname, transport => $to, protocol => $po, status => undef };
395 1         5 $self->log_output('notice','core','Successfully added profile "'.$fullname.'"');
396 1         10 my $lrc=Net::DRI::Protocol::ResultStatus->new_success('Profile "'.$name.'" added successfully','en');
397 1 50       9 return $lrc unless defined $rc;
398 0         0 $rc->_set_last($lrc);
399 0         0 return $rc;
400             }
401              
402             sub del_profile
403             {
404 0     0 0 0 my ($self,$name)=@_;
405 0 0       0 if (defined($name))
406             {
407 0 0       0 err_profile_name_does_not_exist($name) unless $self->exist_profile($name);
408             } else
409             {
410 0 0       0 err_no_current_profile() unless defined $self->{profile};
411 0         0 $name=$self->{profile};
412             }
413              
414 0         0 my $p=$self->{profiles}->{$name};
415 0 0 0     0 $p->{protocol}->end() if ref $p->{protocol} && $p->{protocol}->can('end');
416 0 0 0     0 $p->{transport}->end({registry => $self, profile => $name}) if ref $p->{transport} && $p->{transport}->can('end');
417 0         0 delete($self->{profiles}->{$name});
418 0 0       0 $self->{profile}=undef if $self->{profile} eq $name; ## current profile is not defined anymore
419 0         0 return Net::DRI::Protocol::ResultStatus->new_success('Profile "'.$name.'" deleted successfully','en');
420             }
421              
422             sub end
423             {
424 66     66 0 109 my $self=shift;
425 66         102 foreach my $name (keys %{$self->{profiles}})
  66         263  
426             {
427 1         2 my $p=$self->{profiles}->{$name};
428 1 50 33     23 $p->{transport}->end({protocol => $p->{protocol}}) if ref $p->{transport} && $p->{transport}->can('end');
429 1 50 33     14 $p->{protocol}->end() if ref $p->{protocol} && $p->{protocol}->can('end');
430 1         131 delete $self->{profiles}->{$name}
431             }
432              
433 66 50       524 $self->{driver}->end() if $self->{driver}->can('end');
434 66         131 return;
435             }
436              
437             sub can
438             {
439 316     316 0 6956 my ($self,$what)=@_;
440 316   100     3098 return $self->SUPER::can($what) || $self->driver->can($what);
441             }
442              
443             ####################################################################################################
444             ####################################################################################################
445              
446             sub has_action
447             {
448 0     0 0 0 my ($self,$otype,$oaction)=@_;
449 0         0 my ($po,$to)=$self->protocol_transport();
450 0         0 return $po->has_action($otype,$oaction);
451             }
452              
453             sub process
454             {
455 11     11 0 12 my ($self,$otype,$oaction,$pa,$ta)=@_;
456 11 50       22 $pa=[] unless defined $pa; ## store them ?
457 11 50       17 $ta=[] unless defined $ta;
458 11         25 $self->{last_process}=[$otype,$oaction,$pa,$ta]; ## should be handled more generally by LocalStorage/Exchange
459              
460             ## Automated switch, if enabled
461 11         37 $self->profile_auto_switch($otype,$oaction);
462              
463             ## Current protocol/transport objects for current profile
464 11         19 my ($po,$to)=$self->protocol_transport();
465 10         28 my $trid=$self->generate_trid();
466 10         31 my $ctx={trid => $trid, otype => $otype, oaction => $oaction, phase => 'active', protocol => $po };
467 10         7 my $tosend;
468              
469 10         11 my $ok=eval { $tosend=$po->action($otype,$oaction,$trid,@$pa); 1; }; ## TODO : this may need to be pushed in loop below if we need to change message to send when failure
  10         32  
  10         11  
470 10 50       13 if (! $ok)
471             {
472 0         0 my $err=$@;
473 0         0 return $self->format_error($err);
474             }
475              
476 10         24 $self->{ops}->{$trid}=[0,$tosend,undef]; ## 0 = todo, not sent ## This will be done in/with LocalStorage
477 10         22 my $timeout=$to->timeout();
478 10         50 my $prevalarm=alarm(0); ## removes current alarm
479 10         18 my $pause=$to->pause();
480 10         44 my $start=Time::HiRes::time();
481 10         14 $self->{ops}->{$trid}->[2]=$start;
482              
483 10         8 my $count=0;
484 10         7 my $r;
485 10         21 while (++$count <= $to->retry())
486             {
487 10         126 $self->log_output('debug','core',sprintf('New process loop iteration for TRID=%s with count=%d pause=%f timeout=%f',$trid,$count,$pause,$timeout));
488 10 50 33     49 Time::HiRes::sleep($pause) if (defined($pause) && $pause && ($count > 1));
      33        
489 10 50       19 $self->log_output('warning','core',sprintf('Starting try #%d for TRID=%s',$count,$trid)) if $count>1;
490             $r=eval
491 10         8 {
492 10     0   86 local $SIG{ALRM}=sub { die 'timeout' };
  0         0  
493 10 50       26 alarm($timeout) if ($timeout);
494 10         28 $self->log_output('debug','core',sprintf('Attempting to send data for TRID=%s',$trid));
495 10         24 $to->send($ctx,$tosend,$count,$ta); ## either success or exception, no result code ## TODO : and if open_connection was called inside send ???
496 10         19 $self->log_output('debug','core','Successfully sent data to registry for TRID='.$trid);
497 10         15 $self->{ops}->{$trid}->[0]=1; ## now it is sent
498 10 50       17 return $self->process_back($trid,$po,$to,$otype,$oaction,$count) if $to->is_sync();
499 0         0 my $rc=Net::DRI::Protocol::ResultStatus->new_success('COMMAND_SUCCESSFUL_PENDING');
500 0         0 $rc->_set_trid([ $trid ]);
501 0         0 $self->status($rc);
502 0         0 return $rc;
503             };
504 10 50       31 alarm(0) if $timeout; ## removes our alarm
505 10 50 33     25 if (! defined $r || ! $r) ## some die happened inside the eval (some sources say eval return undef on problem, others say empty string)
506             {
507 0         0 my $err=$@;
508 0 0       0 return $self->format_error($err) if (ref $err eq 'Net::DRI::Protocol::ResultStatus'); ## should probably be a return here see below TODOXXX
509 0 0 0     0 my $is_timeout=(!ref $err && ($err=~m/timeout/))? 1 : 0;
510 0 0       0 $err=$is_timeout? Net::DRI::Exception->new(1,'transport',1,'timeout') : Net::DRI::Exception->new(1,'internal',0,'Error not handled: '.$err) unless ref $err;
    0          
511 0 0       0 $self->log_output('debug','core',$is_timeout? 'Got timeout for TRID='.$trid : 'Got error for TRID='.$trid.' : '.$err->as_string());
512 0 0       0 next if $to->try_again($ctx,$po,$err,$count,$is_timeout,$self->{ops}->{$trid}->[0],\$pause,\$timeout); ## will determine if 1) we break now the loop/we propagate the error (fatal error) 2) we retry
513 0         0 die $err;
514             }
515 10 50       17 last if defined $r;
516             } ## end of while
517 10 50       14 if ($prevalarm) ## re-enable previous alarm
518             {
519 0         0 $prevalarm-=Time::HiRes::time()-$start; ## try to take into account the time spent here
520 0 0       0 alarm($prevalarm) if $prevalarm > 0;
521             }
522 10 50       14 Net::DRI::Exception->die(0,'transport',1,sprintf('Unable to communicate with registry after %d tries for a total delay of %.03f seconds',$to->retry(),Time::HiRes::time()-$start)) unless defined $r;
523 10         54 return $r;
524             }
525              
526             sub format_error
527             {
528 0     0 0 0 my ($self,$err)=@_;
529 0 0       0 if (ref($err) eq 'Net::DRI::Protocol::ResultStatus')
530             {
531 0         0 $self->status($err); ## should that be done above also ? TODOXXX
532 0         0 return $err;
533             }
534 0 0       0 $err=Net::DRI::Exception->new(1,'internal',0,'Error not handled: '.$err) unless ref($err);
535 0         0 die($err);
536             }
537              
538             ## also called directly , when we found something to do for asynchronous case, through TRID (TODO)
539             ## We are already in an eval here, and a while loop for retries
540             sub process_back
541             {
542 10     10 0 64 my ($self,$trid,$po,$to,$otype,$oaction,$count)=@_;
543 10         23 my $ctx={trid => $trid, otype => $otype, oaction => $oaction, protocol => $po }; ## How will we fill that in case of async operation (direct call here) ?
544 10         8 my ($rc,$ri,$oname);
545              
546 10         16 $self->log_output('debug','core','Attempting to receive data from registry for TRID='.$trid);
547 10         22 my $res=$to->receive($ctx,$count); ## a Net::DRI::Data::Raw or die inside
548 10         17 my $stop=Time::HiRes::time();
549 10 50       15 Net::DRI::Exception->die(0,'transport',5,'Unable to receive message from registry') unless defined $res;
550 10         18 $self->log_output('debug','core','Successfully received data from registry for TRID='.$trid);
551 10         10 $self->{ops}->{$trid}->[0]=2; ## now it is received
552 10         12 $self->clear_info(); ## make sure we will overwrite current latest info
553 10         23 $oname=_extract_oname($otype,$oaction,$self->{last_process}->[2]); ## lc() would be good here but this breaks a lot of things !
554 10         32 ($rc,$ri)=$po->reaction($otype,$oaction,$res,$self->{ops}->{$trid}->[1],$oname,$trid); ## $tosend needed to propagate EPP version, for example
555              
556 10 0 33     21 if ($rc->is_closing() || (exists $ri->{_internal} && exists $ri->{_internal}->{must_reconnect} && $ri->{_internal}->{must_reconnect}))
      0        
      33        
557             {
558 0         0 $self->log_output('notice','core','Registry closed connection, we will automatically reconnect during next exchange');
559 0         0 $to->current_state(0);
560             }
561 10         11 delete($ri->{_internal});
562              
563             ## Set latest status from what we got
564 10         19 $self->status($rc);
565              
566 10         22 $ri->{session}->{exchange}->{transport}=$to->name().'/'.$to->version();
567 10         79 $ri->{session}->{exchange}->{registry}=$self->name();
568 10         40 $ri->{session}->{exchange}->{profile}=$self->profile();
569              
570             ## set_info stores also data in last_data, so we make sure to call last for current object
571 10         36 foreach my $type (keys(%$ri))
572             {
573 20         16 foreach my $key (keys(%{$ri->{$type}}))
  20         30  
574             {
575 20 100 66     85 next if ($oname && ($type eq $otype) && ($key eq $oname));
      66        
576 10         21 $self->set_info($type,$key,$ri->{$type}->{$key});
577             }
578             }
579              
580             ## Now set the last info, the one regarding directly the object
581 10 50 33     38 if ($oname && $otype)
582             {
583 10         13 my $rli={ result_status => $rc };
584 10 50 33     36 $rli=$ri->{$otype}->{$oname} if (exists($ri->{$otype}) && exists($ri->{$otype}->{$oname})); ## result_status already done in Protocol
585 10         24 $self->set_info($otype,$oname,$rli);
586             }
587              
588             ## Not before !
589             ## Remove all ResultStatus object, to avoid all circular references
590 10         16 foreach my $v1 (values(%$ri))
591             {
592 20         14 foreach my $v2 (values(%{$v1}))
  20         22  
593             {
594 20 100       41 delete($v2->{result_status}) if exists($v2->{result_status});
595             }
596             }
597              
598             ## the fact that here we copy the session/exchange branch before putting it inside the $rc object is very important
599             ## see comments above in try_restore_from_cache() for details
600 10         9 $ri->{session}->{exchange}={ %{$ri->{session}->{exchange}}, duration_seconds => $stop-$self->{ops}->{$trid}->[2], raw_command => $self->{ops}->{$trid}->[1]->as_string(), raw_reply => $res->as_string(), object_type => $otype, object_action => $oaction };
  10         46  
601 10 50       36 $ri->{session}->{exchange}->{object_name}=$oname if $oname;
602 10         24 $rc->_set_data($ri);
603 10         20 delete($self->{ops}->{$trid});
604 10         94 return $rc;
605             }
606              
607             sub _extract_oname
608             {
609 10     10   10 my ($otype,$oaction,$pa)=@_;
610              
611 10 50 33     22 return 'domains' if ($otype eq 'account' && $oaction eq 'list_domains');
612 10         9 my $o=$pa->[0];
613 10 50       16 return 'session' unless defined($o);
614 10 50       13 $o=$o->[1] if (ref($o) eq 'ARRAY'); ## should be enough for _multi but still a little strange
615 10 50       33 return (Net::DRI::Util::normalize_name($otype,$o))[1] unless ref($o); ## ?? ## TODO ## this fails t/Net/DRI/Protocol/EPP/Extensions/Nominet.t line 306
616 0 0       0 return (Net::DRI::Util::normalize_name('nsgroup',$otype eq 'nsgroup'? $o->name() : $o->get_details(1)))[1] if Net::DRI::Util::isa_hosts($o);
    0          
617 0 0       0 return $o->srid() if Net::DRI::Util::isa_contact($o);
618 0         0 return 'session';
619             }
620              
621             ####################################################################################################
622              
623             sub protocol_capable
624             {
625 7     7 0 9 my ($ndr,$op,$subop,$action)=@_;
626 7 50 33     19 return 0 unless ($op && $subop); ## $action may be undefined
627 7         8 my $po=$ndr->protocol();
628 7         12 my $cap=$po->capabilities(); ## hashref
629              
630             return 0 unless ($cap && (ref($cap) eq 'HASH') && exists($cap->{$op})
631             && (ref($cap->{$op}) eq 'HASH') && exists($cap->{$op}->{$subop})
632 7 50 33     65 && (ref($cap->{$op}->{$subop}) eq 'ARRAY'));
      33        
      33        
      33        
      33        
633              
634 7 100 66     26 return 1 unless (defined($action) && $action);
635              
636 4         4 foreach my $a (@{$cap->{$op}->{$subop}})
  4         8  
637             {
638 6 100       21 return 1 if ($a eq $action);
639             }
640 0         0 return 0;
641             }
642              
643             sub log_output
644             {
645 136     136 0 272 my ($self,$level,$where,$msg)=@_;
646 136         423 my $r=$self->name();
647 136 100       624 $r.='.'.$self->{profile} if (defined $self->{profile});
648 136         239 $msg='('.$r.') '.$msg;
649 136         501 return $self->SUPER::log_output($level,$where,$msg);
650             }
651              
652             ####################################################################################################
653              
654             sub AUTOLOAD
655             {
656 13     13   18 my ($self,@args)=@_;
657 13         12 my $attr=$AUTOLOAD;
658 13         40 $attr=~s/.*:://;
659 13 50       33 return unless $attr=~m/[^A-Z]/; ## skip DESTROY and all-cap methods
660              
661 13         24 my $drd=$self->driver(); ## This is a DRD object
662 13 50 33     77 Net::DRI::Exception::method_not_implemented($attr,$drd) unless ref $drd && $drd->can($attr);
663 13         49 $self->log_output('debug','core',sprintf('Calling %s from Net::DRI::Registry',$attr));
664 13         38 return $drd->$attr($self,@args);
665             }
666              
667             ####################################################################################################
668             1;