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