line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
# |
2
|
|
|
|
|
|
|
# This file is part of Config-Model |
3
|
|
|
|
|
|
|
# |
4
|
|
|
|
|
|
|
# This software is Copyright (c) 2005-2022 by Dominique Dumont. |
5
|
|
|
|
|
|
|
# |
6
|
|
|
|
|
|
|
# This is free software, licensed under: |
7
|
|
|
|
|
|
|
# |
8
|
|
|
|
|
|
|
# The GNU Lesser General Public License, Version 2.1, February 1999 |
9
|
|
|
|
|
|
|
# |
10
|
|
|
|
|
|
|
package Config::Model::Warper 2.153; # TRIAL |
11
|
|
|
|
|
|
|
|
12
|
59
|
|
|
59
|
|
477
|
use Mouse; |
|
59
|
|
|
|
|
156
|
|
|
59
|
|
|
|
|
370
|
|
13
|
|
|
|
|
|
|
|
14
|
59
|
|
|
59
|
|
22765
|
use Log::Log4perl qw(get_logger :levels); |
|
59
|
|
|
|
|
170
|
|
|
59
|
|
|
|
|
398
|
|
15
|
59
|
|
|
59
|
|
7841
|
use Data::Dumper; |
|
59
|
|
|
|
|
189
|
|
|
59
|
|
|
|
|
3759
|
|
16
|
59
|
|
|
59
|
|
548
|
use Storable qw/dclone/; |
|
59
|
|
|
|
|
172
|
|
|
59
|
|
|
|
|
3472
|
|
17
|
59
|
|
|
59
|
|
489
|
use Config::Model::Exception; |
|
59
|
|
|
|
|
171
|
|
|
59
|
|
|
|
|
3159
|
|
18
|
59
|
|
|
59
|
|
37007
|
use List::MoreUtils qw/any/; |
|
59
|
|
|
|
|
844478
|
|
|
59
|
|
|
|
|
431
|
|
19
|
59
|
|
|
59
|
|
66188
|
use Carp; |
|
59
|
|
|
|
|
201
|
|
|
59
|
|
|
|
|
124790
|
|
20
|
|
|
|
|
|
|
|
21
|
|
|
|
|
|
|
has 'follow' => ( is => 'ro', isa => 'HashRef[Str]', required => 1 ); |
22
|
|
|
|
|
|
|
has 'rules' => ( is => 'ro', isa => 'ArrayRef', required => 1 ); |
23
|
|
|
|
|
|
|
|
24
|
|
|
|
|
|
|
has 'warped_object' => ( |
25
|
|
|
|
|
|
|
is => 'ro', |
26
|
|
|
|
|
|
|
isa => 'Config::Model::AnyThing', |
27
|
|
|
|
|
|
|
handles => ['needs_check'], |
28
|
|
|
|
|
|
|
weak_ref => 1, |
29
|
|
|
|
|
|
|
required => 1 |
30
|
|
|
|
|
|
|
); |
31
|
|
|
|
|
|
|
|
32
|
|
|
|
|
|
|
has '_values' => ( |
33
|
|
|
|
|
|
|
traits => ['Hash'], |
34
|
|
|
|
|
|
|
is => 'ro', |
35
|
|
|
|
|
|
|
isa => 'HashRef[HashRef | Str | Undef ]', |
36
|
|
|
|
|
|
|
default => sub { {} }, |
37
|
|
|
|
|
|
|
handles => { |
38
|
|
|
|
|
|
|
_set_value => 'set', |
39
|
|
|
|
|
|
|
_get_value => 'get', |
40
|
|
|
|
|
|
|
_value_keys => 'keys', |
41
|
|
|
|
|
|
|
}, |
42
|
|
|
|
|
|
|
); |
43
|
|
|
|
|
|
|
|
44
|
|
|
|
|
|
|
sub _get_value_gist { |
45
|
559
|
|
|
559
|
|
798
|
my $self = shift; |
46
|
559
|
|
|
|
|
772
|
my $warper_name = shift; |
47
|
559
|
|
|
|
|
1225
|
my $item = $self->_get_value($warper_name); |
48
|
|
|
|
|
|
|
|
49
|
559
|
100
|
|
|
|
7347
|
return ref($item) eq 'HASH' ? join(',', each %$item) : $item; |
50
|
|
|
|
|
|
|
} |
51
|
|
|
|
|
|
|
|
52
|
|
|
|
|
|
|
has [qw/ _computed_masters _warped_nodes _registered_values/] => ( |
53
|
|
|
|
|
|
|
is => 'rw', |
54
|
|
|
|
|
|
|
isa => 'HashRef', |
55
|
|
|
|
|
|
|
init_arg => undef, # can't use this param in constructor |
56
|
|
|
|
|
|
|
default => sub { {} }, |
57
|
|
|
|
|
|
|
); |
58
|
|
|
|
|
|
|
|
59
|
|
|
|
|
|
|
has allowed => ( is => 'rw', isa => 'ArrayRef' ); |
60
|
|
|
|
|
|
|
has morph => ( is => 'ro', isa => 'Bool' ); |
61
|
|
|
|
|
|
|
|
62
|
|
|
|
|
|
|
my $logger = get_logger("Warper"); |
63
|
|
|
|
|
|
|
|
64
|
|
|
|
|
|
|
# create the object, check args, but don't do anything else |
65
|
|
|
|
|
|
|
sub BUILD { |
66
|
438
|
|
|
438
|
1
|
879
|
my $self = shift; |
67
|
|
|
|
|
|
|
|
68
|
438
|
|
|
|
|
1199
|
$logger->trace( "Warper new: created for " . $self->name ); |
69
|
438
|
|
|
|
|
4409
|
$self->check_warp_args; |
70
|
|
|
|
|
|
|
|
71
|
437
|
|
|
|
|
1549
|
$self->register_to_all_warp_masters; |
72
|
437
|
|
|
|
|
1419
|
$self->refresh_values_from_master; |
73
|
437
|
|
|
|
|
17848
|
$self->do_warp; |
74
|
|
|
|
|
|
|
} |
75
|
|
|
|
|
|
|
|
76
|
|
|
|
|
|
|
# should be called only at startup |
77
|
|
|
|
|
|
|
sub register_to_all_warp_masters { |
78
|
444
|
|
|
444
|
0
|
673
|
my $self = shift; |
79
|
|
|
|
|
|
|
|
80
|
444
|
|
|
|
|
1055
|
my $follow = $self->follow; |
81
|
|
|
|
|
|
|
|
82
|
|
|
|
|
|
|
# now, follow is only { w1 => 'warp1', w2 => 'warp2'} |
83
|
444
|
|
|
|
|
1063
|
foreach my $warper_name ( keys %$follow ) { |
84
|
576
|
|
|
|
|
1443
|
$self->register_to_one_warp_master($warper_name); |
85
|
|
|
|
|
|
|
} |
86
|
|
|
|
|
|
|
|
87
|
|
|
|
|
|
|
} |
88
|
|
|
|
|
|
|
|
89
|
|
|
|
|
|
|
sub register_to_one_warp_master { |
90
|
576
|
|
|
576
|
0
|
833
|
my $self = shift; |
91
|
576
|
|
50
|
|
|
1271
|
my $warper_name = shift || die "register_to_one_warp_master: missing warper_name"; |
92
|
|
|
|
|
|
|
|
93
|
576
|
|
|
|
|
1121
|
my $follow = $self->follow; |
94
|
576
|
|
|
|
|
1053
|
my $warper_path = $follow->{$warper_name}; |
95
|
576
|
|
|
|
|
1117
|
$logger->debug( "Warper register_to_one_warp_master: '", $self->name, "' follows '$warper_name'" ); |
96
|
|
|
|
|
|
|
|
97
|
|
|
|
|
|
|
# need to register also to all warped_nodes found on the path |
98
|
576
|
|
|
|
|
4660
|
my @command = ($warper_path); |
99
|
576
|
|
|
|
|
1027
|
my $warper; |
100
|
|
|
|
|
|
|
my $warped_node; |
101
|
576
|
|
|
|
|
1252
|
my $obj = $self->warped_object; |
102
|
576
|
|
|
|
|
1437
|
my $reg_values = $self->_registered_values; |
103
|
|
|
|
|
|
|
|
104
|
576
|
100
|
|
|
|
1342
|
return if defined $reg_values->{$warper_name}; |
105
|
|
|
|
|
|
|
|
106
|
569
|
|
|
|
|
1306
|
while (@command) { |
107
|
|
|
|
|
|
|
|
108
|
|
|
|
|
|
|
# may return undef object |
109
|
1275
|
|
|
|
|
4521
|
( $obj, @command ) = $obj->grab( |
110
|
|
|
|
|
|
|
step => \@command, |
111
|
|
|
|
|
|
|
mode => 'step_by_step', |
112
|
|
|
|
|
|
|
grab_non_available => 1, |
113
|
|
|
|
|
|
|
); |
114
|
|
|
|
|
|
|
|
115
|
1275
|
100
|
|
|
|
3182
|
if ( not defined $obj ) { |
116
|
87
|
|
|
|
|
427
|
$logger->debug("Warper register_to_one_warp_master: aborted steps. Left '@command'"); |
117
|
87
|
|
|
|
|
679
|
last; |
118
|
|
|
|
|
|
|
} |
119
|
|
|
|
|
|
|
|
120
|
1188
|
|
|
|
|
3009
|
my $obj_loc = $obj->location; |
121
|
|
|
|
|
|
|
|
122
|
1188
|
|
|
|
|
3906
|
$logger->debug("Warper register_to_one_warp_master: step to master $obj_loc"); |
123
|
|
|
|
|
|
|
|
124
|
1188
|
100
|
100
|
|
|
14806
|
if ( $obj->isa('Config::Model::Value') or $obj->isa('Config::Model::CheckList')) { |
125
|
482
|
|
|
|
|
817
|
$warper = $obj; |
126
|
482
|
100
|
|
|
|
1044
|
if ( defined $warped_node ) { |
127
|
|
|
|
|
|
|
|
128
|
|
|
|
|
|
|
# keep obj ref to be able to unregister later on |
129
|
37
|
|
|
|
|
249
|
$self->_warped_nodes->{$warped_node}{$warper_name} = $obj; |
130
|
|
|
|
|
|
|
} |
131
|
482
|
|
|
|
|
1331
|
last; |
132
|
|
|
|
|
|
|
} |
133
|
|
|
|
|
|
|
|
134
|
706
|
100
|
|
|
|
3266
|
if ( $obj->isa('Config::Model::WarpedNode') ) { |
135
|
124
|
|
|
|
|
835
|
$logger->debug("Warper register_to_one_warp_master: register to warped_node $obj_loc"); |
136
|
124
|
50
|
|
|
|
933
|
if ( defined $warped_node ) { |
137
|
|
|
|
|
|
|
|
138
|
|
|
|
|
|
|
# keep obj ref to be able to unregister later on |
139
|
0
|
|
|
|
|
0
|
$self->_warped_nodes->{$warped_node}{$warper_name} = $obj; |
140
|
|
|
|
|
|
|
} |
141
|
124
|
|
|
|
|
216
|
$warped_node = $obj_loc; |
142
|
124
|
|
|
|
|
367
|
$obj->register( $self, $warper_name ); |
143
|
|
|
|
|
|
|
} |
144
|
|
|
|
|
|
|
} |
145
|
|
|
|
|
|
|
|
146
|
569
|
50
|
100
|
|
|
2303
|
if ( defined $warper and scalar @command ) { |
147
|
0
|
|
|
|
|
0
|
Config::Model::Exception::Model->throw( |
148
|
|
|
|
|
|
|
object => $self->warped_object, |
149
|
|
|
|
|
|
|
error => "Some steps are left (@command) from warper path $warper_path", |
150
|
|
|
|
|
|
|
); |
151
|
|
|
|
|
|
|
} |
152
|
|
|
|
|
|
|
|
153
|
|
|
|
|
|
|
$logger->debug( |
154
|
569
|
100
|
|
|
|
1566
|
"Warper register_to_one_warp_master:", |
155
|
|
|
|
|
|
|
$self->name, |
156
|
|
|
|
|
|
|
" is warped by $warper_name => '$warper_path' location in tree is: '", |
157
|
|
|
|
|
|
|
defined $warper ? $warper->name : 'unknown', "'" |
158
|
|
|
|
|
|
|
); |
159
|
|
|
|
|
|
|
|
160
|
569
|
100
|
|
|
|
4544
|
return unless defined $warper; |
161
|
|
|
|
|
|
|
|
162
|
482
|
50
|
66
|
|
|
1851
|
Config::Model::Exception::Model->throw( |
163
|
|
|
|
|
|
|
object => $self->warped_object, |
164
|
|
|
|
|
|
|
error => "warper $warper_name => '$warper_path' is not a leaf" |
165
|
|
|
|
|
|
|
) unless $warper->isa('Config::Model::Value') or $obj->isa('Config::Model::CheckList'); |
166
|
|
|
|
|
|
|
|
167
|
|
|
|
|
|
|
# warp will register this value object in another value object |
168
|
|
|
|
|
|
|
# (the warper). When the warper gets a new value, it will |
169
|
|
|
|
|
|
|
# modify the warped object according to the data passed by the |
170
|
|
|
|
|
|
|
# user. |
171
|
|
|
|
|
|
|
|
172
|
482
|
|
|
|
|
1831
|
my $type = $warper->register( $self, $warper_name ); |
173
|
|
|
|
|
|
|
|
174
|
482
|
|
|
|
|
1236
|
$reg_values->{$warper_name} = $warper; |
175
|
|
|
|
|
|
|
|
176
|
|
|
|
|
|
|
# store current warp master value |
177
|
482
|
100
|
|
|
|
2419
|
if ( $type eq 'computed' ) { |
178
|
1
|
|
|
|
|
11
|
$self->_computed_masters->{$warper_name} = $warper; |
179
|
|
|
|
|
|
|
} |
180
|
|
|
|
|
|
|
} |
181
|
|
|
|
|
|
|
|
182
|
|
|
|
|
|
|
sub refresh_affected_registrations { |
183
|
7
|
|
|
7
|
0
|
15
|
my ( $self, $warped_node_location ) = @_; |
184
|
|
|
|
|
|
|
|
185
|
7
|
|
|
|
|
15
|
my $wnref = $self->_warped_nodes; |
186
|
|
|
|
|
|
|
|
187
|
7
|
|
|
|
|
16
|
$logger->debug( "Warper refresh_affected_registrations: called on", |
188
|
|
|
|
|
|
|
$self->name, " from $warped_node_location'" ); |
189
|
|
|
|
|
|
|
|
190
|
|
|
|
|
|
|
#return unless defined $wnref ; |
191
|
|
|
|
|
|
|
|
192
|
|
|
|
|
|
|
# remove and unregister obj affected by this warped node |
193
|
7
|
|
|
|
|
60
|
my $ref = delete $wnref->{$warped_node_location}; |
194
|
|
|
|
|
|
|
|
195
|
7
|
|
|
|
|
22
|
foreach my $warper_name ( keys %$ref ) { |
196
|
4
|
|
|
|
|
12
|
$logger->debug( "Warper refresh_affected_registrations: ", |
197
|
|
|
|
|
|
|
$self->name, " unregisters from $warper_name'" ); |
198
|
4
|
|
|
|
|
32
|
delete $self->_registered_values->{$warper_name}; |
199
|
4
|
|
|
|
|
9
|
$ref->{$warper_name}->unregister( $self->name ); |
200
|
|
|
|
|
|
|
} |
201
|
|
|
|
|
|
|
|
202
|
7
|
|
|
|
|
19
|
$self->register_to_all_warp_masters; |
203
|
|
|
|
|
|
|
|
204
|
|
|
|
|
|
|
#map { $self->register_to_one_warp_master($_) } keys %$ref; |
205
|
|
|
|
|
|
|
} |
206
|
|
|
|
|
|
|
|
207
|
|
|
|
|
|
|
# should be called only at startup |
208
|
|
|
|
|
|
|
sub refresh_values_from_master { |
209
|
437
|
|
|
437
|
0
|
716
|
my $self = shift; |
210
|
|
|
|
|
|
|
|
211
|
|
|
|
|
|
|
# should get new value from warp master |
212
|
|
|
|
|
|
|
|
213
|
437
|
|
|
|
|
1006
|
my $follow = $self->follow; |
214
|
|
|
|
|
|
|
|
215
|
|
|
|
|
|
|
# now, follow is only { w1 => 'warp1', w2 => 'warp2'} |
216
|
|
|
|
|
|
|
|
217
|
|
|
|
|
|
|
# should try to get values only for unregister or computed warp masters |
218
|
437
|
|
|
|
|
1232
|
foreach my $warper_name ( keys %$follow ) { |
219
|
562
|
|
|
|
|
4909
|
my $warper_path = $follow->{$warper_name}; |
220
|
562
|
|
|
|
|
1316
|
$logger->debug( "Warper trigger: ", $self->name, " following $warper_name" ); |
221
|
|
|
|
|
|
|
|
222
|
|
|
|
|
|
|
# warper can itself be warped out (part of a warped out node). |
223
|
|
|
|
|
|
|
# not just 'not available'. |
224
|
|
|
|
|
|
|
|
225
|
562
|
|
|
|
|
5333
|
my $warper = $self->warped_object->grab( |
226
|
|
|
|
|
|
|
step => $warper_path, |
227
|
|
|
|
|
|
|
mode => 'loose', |
228
|
|
|
|
|
|
|
); |
229
|
|
|
|
|
|
|
|
230
|
562
|
100
|
100
|
|
|
2738
|
if ( defined $warper and $warper->get_type eq 'leaf' ) { |
|
|
100
|
66
|
|
|
|
|
|
|
50
|
|
|
|
|
|
231
|
|
|
|
|
|
|
# read the warp master values, so I can warp myself just after. |
232
|
473
|
|
|
|
|
1395
|
my $warper_value = $warper->fetch('allow_undef'); |
233
|
473
|
|
100
|
|
|
3085
|
my $str = $warper_value // '<undef>'; |
234
|
473
|
|
|
|
|
2253
|
$logger->debug( "Warper: '$warper_name' value is: '$str'" ); |
235
|
473
|
|
|
|
|
4783
|
$self->_set_value( $warper_name => $warper_value ); |
236
|
|
|
|
|
|
|
} |
237
|
|
|
|
|
|
|
elsif ( defined $warper and $warper->get_type eq 'check_list' ) { |
238
|
2
|
50
|
|
|
|
6
|
if ($logger->is_debug) { |
239
|
0
|
|
|
|
|
0
|
my $warper_value = $warper->fetch(); |
240
|
0
|
|
|
|
|
0
|
$logger->debug( "Warper: '$warper_name' checked values are: '$warper_value'" ); |
241
|
|
|
|
|
|
|
} |
242
|
|
|
|
|
|
|
# store checked values are data structure, not as string |
243
|
2
|
|
|
|
|
19
|
$self->_set_value( $warper_name => scalar $warper->get_checked_list_as_hash() ); |
244
|
|
|
|
|
|
|
} |
245
|
|
|
|
|
|
|
elsif ( defined $warper ) { |
246
|
0
|
|
|
|
|
0
|
Config::Model::Exception::Model->throw( |
247
|
|
|
|
|
|
|
error => "warp error: warp 'follow' parameter " |
248
|
|
|
|
|
|
|
. "does not point to a leaf element", |
249
|
|
|
|
|
|
|
object => $self->warped_object |
250
|
|
|
|
|
|
|
); |
251
|
|
|
|
|
|
|
} |
252
|
|
|
|
|
|
|
else { |
253
|
|
|
|
|
|
|
# consider that the warp master value is undef |
254
|
87
|
|
|
|
|
329
|
$self->_set_value( $warper_name, '' ); |
255
|
87
|
|
|
|
|
3850
|
$logger->debug("Warper: '$warper_name' is not available"); |
256
|
|
|
|
|
|
|
} |
257
|
|
|
|
|
|
|
} |
258
|
|
|
|
|
|
|
|
259
|
|
|
|
|
|
|
} |
260
|
|
|
|
|
|
|
|
261
|
|
|
|
|
|
|
sub name { |
262
|
3891
|
|
|
3891
|
0
|
5737
|
my $self = shift; |
263
|
3891
|
|
|
|
|
11925
|
return "Warper of " . $self->warped_object->name; |
264
|
|
|
|
|
|
|
} |
265
|
|
|
|
|
|
|
|
266
|
|
|
|
|
|
|
# And I'm going to warp them ... |
267
|
|
|
|
|
|
|
sub warp_them { |
268
|
0
|
|
|
0
|
0
|
0
|
my $self = shift; |
269
|
|
|
|
|
|
|
|
270
|
|
|
|
|
|
|
# retrieve current value if not provided |
271
|
0
|
0
|
|
|
|
0
|
my $value = |
272
|
|
|
|
|
|
|
@_ |
273
|
|
|
|
|
|
|
? $_[0] |
274
|
|
|
|
|
|
|
: $self->fetch_no_check; |
275
|
|
|
|
|
|
|
|
276
|
0
|
|
|
|
|
0
|
foreach my $ref ( @{ $self->{warp_these_objects} } ) { |
|
0
|
|
|
|
|
0
|
|
277
|
0
|
|
|
|
|
0
|
my ( $warped, $warp_index ) = @$ref; |
278
|
0
|
0
|
|
|
|
0
|
next unless defined $warped; # $warped is a weak ref and may vanish |
279
|
|
|
|
|
|
|
|
280
|
|
|
|
|
|
|
# pure warp of object |
281
|
0
|
0
|
|
|
|
0
|
$logger->debug( |
282
|
|
|
|
|
|
|
"Warper ", $self->name, |
283
|
|
|
|
|
|
|
" warp_them: (value ", |
284
|
|
|
|
|
|
|
( defined $value ? $value : 'undefined' ), |
285
|
|
|
|
|
|
|
") warping '", $warped->name, "'" |
286
|
|
|
|
|
|
|
); |
287
|
0
|
|
|
|
|
0
|
$warped->warp( $value, $warp_index ); |
288
|
|
|
|
|
|
|
} |
289
|
|
|
|
|
|
|
} |
290
|
|
|
|
|
|
|
|
291
|
|
|
|
|
|
|
sub check_warp_args { |
292
|
438
|
|
|
438
|
0
|
762
|
my $self = shift; |
293
|
|
|
|
|
|
|
|
294
|
|
|
|
|
|
|
# check that rules element are array ref and store them for |
295
|
|
|
|
|
|
|
# error checking |
296
|
438
|
|
|
|
|
1086
|
my $rules_ref = $self->rules; |
297
|
|
|
|
|
|
|
|
298
|
438
|
50
|
|
|
|
2198
|
my @rules = |
|
|
50
|
|
|
|
|
|
299
|
|
|
|
|
|
|
ref $rules_ref eq 'HASH' ? %$rules_ref |
300
|
|
|
|
|
|
|
: ref $rules_ref eq 'ARRAY' ? @$rules_ref |
301
|
|
|
|
|
|
|
: Config::Model::Exception::Model->throw( |
302
|
|
|
|
|
|
|
error => "warp error: warp 'rules' parameter " . "is not a ref ($rules_ref)", |
303
|
|
|
|
|
|
|
object => $self->warped_object |
304
|
|
|
|
|
|
|
); |
305
|
|
|
|
|
|
|
|
306
|
438
|
|
|
|
|
1166
|
my $allowed = $self->allowed; |
307
|
|
|
|
|
|
|
|
308
|
438
|
|
|
|
|
1398
|
for ( my $r_idx = 0 ; $r_idx < $#rules ; $r_idx += 2 ) { |
309
|
1385
|
|
|
|
|
2316
|
my $key_set = $rules[$r_idx]; |
310
|
1385
|
50
|
|
|
|
3431
|
my @keys = ref($key_set) ? @$key_set : ($key_set); |
311
|
|
|
|
|
|
|
|
312
|
1385
|
|
|
|
|
2100
|
my $v = $rules[ $r_idx + 1 ]; |
313
|
1385
|
100
|
|
|
|
2865
|
Config::Model::Exception::Model->throw( |
314
|
|
|
|
|
|
|
object => $self->warped_object, |
315
|
|
|
|
|
|
|
error => "rules value for @keys is not a hash ref ($v)" |
316
|
|
|
|
|
|
|
) unless ref($v) eq 'HASH'; |
317
|
|
|
|
|
|
|
|
318
|
1384
|
|
|
|
|
3468
|
foreach my $pkey ( keys %$v ) { |
319
|
|
|
|
|
|
|
Config::Model::Exception::Model->throw( |
320
|
|
|
|
|
|
|
object => $self->warped_object, |
321
|
|
|
|
|
|
|
error => "Warp rules error for '@keys': '$pkey' " |
322
|
|
|
|
|
|
|
. "parameter is not allowed, " |
323
|
|
|
|
|
|
|
. "expected '" |
324
|
|
|
|
|
|
|
. join( "' or '", @$allowed ) . "'" |
325
|
1428
|
50
|
|
3928
|
|
5289
|
) unless any {$pkey eq $_} @$allowed ; |
|
3928
|
|
|
|
|
9726
|
|
326
|
|
|
|
|
|
|
} |
327
|
|
|
|
|
|
|
} |
328
|
|
|
|
|
|
|
} |
329
|
|
|
|
|
|
|
|
330
|
|
|
|
|
|
|
sub _dclone_key { |
331
|
1
|
50
|
|
1
|
|
8
|
return map { ref $_ ? [@$_] : $_ } @_; |
|
1
|
|
|
|
|
12
|
|
332
|
|
|
|
|
|
|
} |
333
|
|
|
|
|
|
|
|
334
|
|
|
|
|
|
|
# Internal. This method will change element properties (like level) according to the warp effect. |
335
|
|
|
|
|
|
|
# For instance, if a warp rule make a node no longer available in a model, its level must change to |
336
|
|
|
|
|
|
|
# 'hidden' |
337
|
|
|
|
|
|
|
sub set_parent_element_property { |
338
|
754
|
|
|
754
|
0
|
1626
|
my ( $self, $arg_ref ) = @_; |
339
|
|
|
|
|
|
|
|
340
|
754
|
|
|
|
|
3442
|
my $warped_object = $self->warped_object; |
341
|
|
|
|
|
|
|
|
342
|
754
|
|
|
|
|
1676
|
my @properties = qw/level/; |
343
|
|
|
|
|
|
|
|
344
|
754
|
100
|
|
|
|
2694
|
if ( defined $warped_object->index_value ) { |
345
|
11
|
|
|
|
|
45
|
$logger->debug("Warper set_parent_element_property: called on hash or list, aborted"); |
346
|
11
|
|
|
|
|
80
|
return; |
347
|
|
|
|
|
|
|
} |
348
|
|
|
|
|
|
|
|
349
|
743
|
|
|
|
|
1675
|
my $parent = $warped_object->parent; |
350
|
743
|
|
|
|
|
1651
|
my $elt_name = $warped_object->element_name; |
351
|
743
|
|
|
|
|
1536
|
foreach my $property_name (@properties) { |
352
|
743
|
|
|
|
|
1365
|
my $v = $arg_ref->{$property_name}; |
353
|
743
|
100
|
|
|
|
1592
|
if ( defined $v ) { |
354
|
76
|
|
|
|
|
257
|
$logger->debug( "Warper set_parent_element_property: set '", |
355
|
|
|
|
|
|
|
$parent->name, " $elt_name' $property_name with $v" ); |
356
|
76
|
|
|
|
|
692
|
$parent->set_element_property( |
357
|
|
|
|
|
|
|
property => $property_name, |
358
|
|
|
|
|
|
|
element => $elt_name, |
359
|
|
|
|
|
|
|
value => $v, |
360
|
|
|
|
|
|
|
); |
361
|
|
|
|
|
|
|
} |
362
|
|
|
|
|
|
|
else { |
363
|
|
|
|
|
|
|
|
364
|
|
|
|
|
|
|
# reset ensures that property is reset to known state by default |
365
|
667
|
|
|
|
|
2482
|
$logger->debug("Warper set_parent_element_property: reset $property_name"); |
366
|
667
|
|
|
|
|
5758
|
$parent->reset_element_property( |
367
|
|
|
|
|
|
|
property => $property_name, |
368
|
|
|
|
|
|
|
element => $elt_name, |
369
|
|
|
|
|
|
|
); |
370
|
|
|
|
|
|
|
} |
371
|
|
|
|
|
|
|
} |
372
|
|
|
|
|
|
|
} |
373
|
|
|
|
|
|
|
|
374
|
|
|
|
|
|
|
# try to actually warp (change properties) of a warped object. |
375
|
|
|
|
|
|
|
sub trigger { |
376
|
340
|
|
|
340
|
0
|
543
|
my $self = shift; |
377
|
|
|
|
|
|
|
|
378
|
340
|
|
|
|
|
505
|
my %old_value_set = %{ $self->_values }; |
|
340
|
|
|
|
|
1504
|
|
379
|
|
|
|
|
|
|
|
380
|
340
|
50
|
|
|
|
945
|
if (@_) { |
381
|
340
|
|
|
|
|
684
|
my ( $value, $warp_name ) = @_; |
382
|
340
|
100
|
|
|
|
815
|
$logger->debug( |
383
|
|
|
|
|
|
|
"Warper: trigger called on ", |
384
|
|
|
|
|
|
|
$self->name, |
385
|
|
|
|
|
|
|
" with value '", |
386
|
|
|
|
|
|
|
defined $value ? $value : '<undef>', |
387
|
|
|
|
|
|
|
"' name $warp_name" |
388
|
|
|
|
|
|
|
); |
389
|
340
|
|
100
|
|
|
3456
|
$self->_set_value( $warp_name => $value || '' ); |
390
|
|
|
|
|
|
|
} |
391
|
|
|
|
|
|
|
|
392
|
|
|
|
|
|
|
# read warp master values that are computed |
393
|
340
|
|
|
|
|
13775
|
my $cm = $self->_computed_masters; |
394
|
340
|
|
|
|
|
848
|
foreach my $name ( keys %$cm ) { |
395
|
0
|
|
|
|
|
0
|
$self->_set_value( $name => $cm->{$name}->fetch ); |
396
|
|
|
|
|
|
|
} |
397
|
|
|
|
|
|
|
|
398
|
|
|
|
|
|
|
# check if new values are different from old values |
399
|
340
|
|
|
|
|
556
|
my $same = 1; |
400
|
340
|
|
|
|
|
809
|
foreach my $name ( $self->_value_keys ) { |
401
|
559
|
|
|
|
|
2944
|
my $old = $old_value_set{$name}; |
402
|
559
|
|
|
|
|
1203
|
my $new = $self->_get_value_gist($name); |
403
|
559
|
100
|
100
|
|
|
4453
|
$same = 0 |
|
|
100
|
66
|
|
|
|
|
|
|
100
|
100
|
|
|
|
|
|
|
|
100
|
|
|
|
|
404
|
|
|
|
|
|
|
if ( $old ? 1 : 0 xor $new ? 1 : 0 ) |
405
|
|
|
|
|
|
|
or ( $old and $new and $new ne $old ); |
406
|
|
|
|
|
|
|
} |
407
|
|
|
|
|
|
|
|
408
|
340
|
100
|
|
|
|
1046
|
if ($same) { |
409
|
59
|
|
|
59
|
|
718
|
no warnings "uninitialized"; |
|
59
|
|
|
|
|
193
|
|
|
59
|
|
|
|
|
23616
|
|
410
|
30
|
50
|
|
|
|
90
|
if ( $logger->is_debug ) { |
411
|
|
|
|
|
|
|
$logger->debug( |
412
|
|
|
|
|
|
|
"Warper: warp skipped because no change in value set ", |
413
|
|
|
|
|
|
|
"(old: '", join( "' '", %old_value_set ), |
414
|
0
|
|
|
|
|
0
|
"' new: '", join( "' '", %{ $self->_values() } ), "')" |
|
0
|
|
|
|
|
0
|
|
415
|
|
|
|
|
|
|
); |
416
|
|
|
|
|
|
|
} |
417
|
30
|
|
|
|
|
219
|
return; |
418
|
|
|
|
|
|
|
} |
419
|
|
|
|
|
|
|
|
420
|
310
|
|
|
|
|
739
|
$self->do_warp; |
421
|
|
|
|
|
|
|
} |
422
|
|
|
|
|
|
|
|
423
|
|
|
|
|
|
|
# undef values are changed to '' so compute_bool no longer returns |
424
|
|
|
|
|
|
|
# undef. It returns either 1 or 0 |
425
|
|
|
|
|
|
|
sub compute_bool { |
426
|
1623
|
|
|
1623
|
0
|
2652
|
my $self = shift; |
427
|
1623
|
|
|
|
|
2670
|
my $expr = shift; |
428
|
|
|
|
|
|
|
|
429
|
1623
|
|
|
|
|
6634
|
$logger->trace("Warper compute_bool: called for '$expr'"); |
430
|
|
|
|
|
|
|
|
431
|
|
|
|
|
|
|
# my $warp_value_set = $self->_values ; |
432
|
1623
|
|
|
|
|
19150
|
$logger->debug( "Warper compute_bool: data:\n", |
433
|
|
|
|
|
|
|
Data::Dumper->Dump( [ $self->_values ], ['data'] ) ); |
434
|
|
|
|
|
|
|
|
435
|
|
|
|
|
|
|
# checklist: $stuff.is_set(&index) |
436
|
|
|
|
|
|
|
# get_value of a checklist gives { 'val1' => 1, 'val2' => 0,...} |
437
|
1623
|
|
|
|
|
103308
|
$expr =~ s/(\$\w+)\.is_set\(([&$"'\w]+)\)/$1.'->{'.$2.'}'/eg; |
|
10
|
|
|
|
|
57
|
|
438
|
|
|
|
|
|
|
|
439
|
1623
|
|
|
|
|
3579
|
$expr =~ s/&(\w+)/\$warped_obj->$1/g; |
440
|
|
|
|
|
|
|
|
441
|
1623
|
|
|
|
|
2696
|
my @init_code; |
442
|
|
|
|
|
|
|
my %eval_data ; |
443
|
1623
|
|
|
|
|
4832
|
foreach my $warper_name ( $self->_value_keys ) { |
444
|
2319
|
|
|
|
|
16251
|
$eval_data{$warper_name} = $self->_get_value($warper_name) ; |
445
|
2319
|
|
|
|
|
33903
|
push @init_code, "my \$$warper_name = \$eval_data{'$warper_name'} ;"; |
446
|
|
|
|
|
|
|
} |
447
|
|
|
|
|
|
|
|
448
|
1623
|
|
|
|
|
6451
|
my $perl_code = join( "\n", @init_code, $expr ); |
449
|
1623
|
|
|
|
|
5473
|
$logger->trace("Warper compute_bool: eval code '$perl_code'"); |
450
|
|
|
|
|
|
|
|
451
|
1623
|
|
|
|
|
11469
|
my $ret; |
452
|
|
|
|
|
|
|
{ |
453
|
1623
|
|
|
|
|
2332
|
my $warped_obj = $self->warped_object ; |
|
1623
|
|
|
|
|
3887
|
|
454
|
59
|
|
|
59
|
|
551
|
no warnings "uninitialized"; |
|
59
|
|
|
|
|
2803
|
|
|
59
|
|
|
|
|
61274
|
|
455
|
1623
|
|
|
|
|
114131
|
$ret = eval($perl_code); ## no critic (ProhibitStringyEval) |
456
|
|
|
|
|
|
|
} |
457
|
|
|
|
|
|
|
|
458
|
1623
|
50
|
|
|
|
6849
|
if ($@) { |
459
|
0
|
|
|
|
|
0
|
Config::Model::Exception::Model->throw( |
460
|
|
|
|
|
|
|
object => $self->warped_object, |
461
|
|
|
|
|
|
|
error => "Warp boolean expression failed:\n$@" . "eval'ed code is: \n$perl_code" |
462
|
|
|
|
|
|
|
); |
463
|
|
|
|
|
|
|
} |
464
|
|
|
|
|
|
|
|
465
|
1623
|
100
|
|
|
|
6970
|
$logger->debug( "compute_bool: eval result: ", ( $ret ? 'true' : 'false' ) ); |
466
|
1623
|
|
|
|
|
15652
|
return $ret; |
467
|
|
|
|
|
|
|
} |
468
|
|
|
|
|
|
|
|
469
|
|
|
|
|
|
|
sub do_warp { |
470
|
754
|
|
|
754
|
0
|
1470
|
my $self = shift; |
471
|
|
|
|
|
|
|
|
472
|
754
|
|
|
|
|
1727
|
my $warp_value_set = $self->_values; |
473
|
754
|
|
|
|
|
26955
|
my $rules = dclone( $self->rules ); |
474
|
754
|
|
|
|
|
3909
|
my %rule_hash = @$rules; |
475
|
|
|
|
|
|
|
|
476
|
|
|
|
|
|
|
# try all boolean expression with warp_value_set to get the |
477
|
|
|
|
|
|
|
# correct rule |
478
|
|
|
|
|
|
|
|
479
|
754
|
|
|
|
|
1542
|
my $found_rule = {}; |
480
|
754
|
|
|
|
|
1465
|
my $found_bool = ''; # this variable may be used later in error message |
481
|
|
|
|
|
|
|
|
482
|
754
|
|
|
|
|
1711
|
foreach my $bool_expr (@$rules) { |
483
|
2913
|
100
|
|
|
|
6469
|
next if ref($bool_expr); # it's a rule not a bool expr |
484
|
1623
|
|
|
|
|
4370
|
my $res = $self->compute_bool($bool_expr); |
485
|
1623
|
100
|
|
|
|
4591
|
next unless $res; |
486
|
333
|
|
|
|
|
640
|
$found_bool = $bool_expr; |
487
|
333
|
|
50
|
|
|
1162
|
$found_rule = $rule_hash{$bool_expr} || {}; |
488
|
333
|
|
|
|
|
1757
|
$logger->trace( |
489
|
|
|
|
|
|
|
"do_warp found rule for '$bool_expr':\n", |
490
|
|
|
|
|
|
|
Data::Dumper->Dump( [$found_rule], ['found_rule'] ) ); |
491
|
333
|
|
|
|
|
20189
|
last; |
492
|
|
|
|
|
|
|
} |
493
|
|
|
|
|
|
|
|
494
|
754
|
100
|
|
|
|
2299
|
if ( $logger->is_info ) { |
495
|
7
|
50
|
|
|
|
41
|
my @warp_str = map { defined $_ ? $_ : 'undef' } keys %$warp_value_set; |
|
7
|
|
|
|
|
27
|
|
496
|
|
|
|
|
|
|
|
497
|
7
|
100
|
|
|
|
45
|
$logger->info( |
498
|
|
|
|
|
|
|
"do_warp: warp called from '$found_bool' on '", |
499
|
|
|
|
|
|
|
$self->warped_object->name, |
500
|
|
|
|
|
|
|
"' with elements '", |
501
|
|
|
|
|
|
|
join( "','", @warp_str ), |
502
|
|
|
|
|
|
|
"', warp rule is ", |
503
|
|
|
|
|
|
|
( scalar %$found_rule ? "" : 'not ' ), |
504
|
|
|
|
|
|
|
"found" |
505
|
|
|
|
|
|
|
); |
506
|
|
|
|
|
|
|
} |
507
|
|
|
|
|
|
|
|
508
|
754
|
|
|
|
|
5779
|
$logger->trace( "do_warp: call set_parent_element_property on '", |
509
|
|
|
|
|
|
|
$self->name, "' with ", Data::Dumper->Dump( [$found_rule], ['found_rule'] ) ); |
510
|
|
|
|
|
|
|
|
511
|
754
|
|
|
|
|
40265
|
$self->set_parent_element_property($found_rule); |
512
|
|
|
|
|
|
|
|
513
|
754
|
|
|
|
|
3021
|
$logger->debug( |
514
|
|
|
|
|
|
|
"do_warp: call set_properties on '", |
515
|
|
|
|
|
|
|
$self->warped_object->name, |
516
|
|
|
|
|
|
|
"' with ", Data::Dumper->Dump( [$found_rule], ['found_rule'] ) ); |
517
|
754
|
|
|
|
|
39273
|
eval { $self->warped_object->set_properties(%$found_rule); }; |
|
754
|
|
|
|
|
3422
|
|
518
|
|
|
|
|
|
|
|
519
|
754
|
100
|
|
|
|
5892
|
if ($@) { |
520
|
1
|
50
|
|
|
|
4
|
my @warp_str = map { defined $_ ? $_ : 'undef' } keys %$warp_value_set; |
|
1
|
|
|
|
|
6
|
|
521
|
1
|
|
|
|
|
2
|
my $e = $@; |
522
|
1
|
50
|
|
|
|
10
|
my $msg = ref $e ? $e->as_string : $e; |
523
|
1
|
|
|
|
|
22
|
Config::Model::Exception::Model->throw( |
524
|
|
|
|
|
|
|
object => $self->warped_object, |
525
|
|
|
|
|
|
|
error => "Warp failed when following '" |
526
|
|
|
|
|
|
|
. join( "','", @warp_str ) |
527
|
|
|
|
|
|
|
. "' from \"$found_bool\". Check model rules:\n\t" |
528
|
|
|
|
|
|
|
. $msg |
529
|
|
|
|
|
|
|
); |
530
|
|
|
|
|
|
|
} |
531
|
|
|
|
|
|
|
} |
532
|
|
|
|
|
|
|
|
533
|
|
|
|
|
|
|
# Usually a warp error occurs when the item is not actually available |
534
|
|
|
|
|
|
|
# or when a setting is wrong. Then guiding the user toward a warp |
535
|
|
|
|
|
|
|
# master value that has a rule attached to it is a good idea. |
536
|
|
|
|
|
|
|
|
537
|
|
|
|
|
|
|
# But sometime, the user wants to remove and item. In this case it |
538
|
|
|
|
|
|
|
# must be warped out by setting a warp master value that has not rule |
539
|
|
|
|
|
|
|
# attached. This case is indicated when $want_remove is set to 1 |
540
|
|
|
|
|
|
|
sub warp_error { |
541
|
7
|
|
|
7
|
1
|
20
|
my ($self) = @_; |
542
|
|
|
|
|
|
|
|
543
|
7
|
50
|
|
|
|
48
|
return '' unless defined $self->{warp}; |
544
|
0
|
|
|
|
|
|
my $follow = $self->{warp}{follow}; |
545
|
0
|
|
|
|
|
|
my @rules = @{ $self->{warp}{rules} }; |
|
0
|
|
|
|
|
|
|
546
|
|
|
|
|
|
|
|
547
|
|
|
|
|
|
|
# follow is either ['warp1','warp2',...] |
548
|
|
|
|
|
|
|
# or { warp1 => {....} , ...} or 'warp' |
549
|
0
|
0
|
|
|
|
|
my @warper_paths = |
|
|
0
|
|
|
|
|
|
550
|
|
|
|
|
|
|
ref($follow) eq 'ARRAY' ? @$follow |
551
|
|
|
|
|
|
|
: ref($follow) eq 'HASH' ? values %$follow |
552
|
|
|
|
|
|
|
: ($follow); |
553
|
|
|
|
|
|
|
|
554
|
0
|
0
|
|
|
|
|
my $str = |
555
|
|
|
|
|
|
|
"You may solve the problem by modifying " |
556
|
|
|
|
|
|
|
. ( @warper_paths > 1 ? "one or more of " : '' ) |
557
|
|
|
|
|
|
|
. "the following configuration parameters:\n"; |
558
|
|
|
|
|
|
|
|
559
|
0
|
|
|
|
|
|
my $expected_error = 'Config::Model::Exception::UnavailableElement'; |
560
|
|
|
|
|
|
|
|
561
|
0
|
|
|
|
|
|
foreach my $warper_path (@warper_paths) { |
562
|
0
|
|
|
|
|
|
my $warper_value; |
563
|
|
|
|
|
|
|
my $warper; |
564
|
|
|
|
|
|
|
|
565
|
|
|
|
|
|
|
# try |
566
|
0
|
|
|
|
|
|
eval { |
567
|
0
|
|
|
|
|
|
$warper = $self->get_warper_object($warper_path); |
568
|
0
|
|
|
|
|
|
$warper_value = $warper->fetch; |
569
|
|
|
|
|
|
|
}; |
570
|
0
|
|
|
|
|
|
my $e = $@; |
571
|
|
|
|
|
|
|
# catch |
572
|
0
|
0
|
|
|
|
|
if ( ref($e) eq $expected_error ) { |
573
|
0
|
|
|
|
|
|
$str .= "\t'$warper_path' which is unavailable\n"; |
574
|
0
|
|
|
|
|
|
next; |
575
|
|
|
|
|
|
|
} |
576
|
|
|
|
|
|
|
|
577
|
0
|
0
|
|
|
|
|
$warper_value = 'undef' unless defined $warper_value; |
578
|
|
|
|
|
|
|
|
579
|
|
|
|
|
|
|
my @choice = |
580
|
0
|
|
|
|
|
|
defined $warper->choice ? @{ $warper->choice } |
581
|
0
|
0
|
|
|
|
|
: $warper->{value_type} eq 'boolean' ? ( 0, 1 ) |
|
|
0
|
|
|
|
|
|
582
|
|
|
|
|
|
|
: (); |
583
|
|
|
|
|
|
|
|
584
|
0
|
|
|
|
|
|
my @try = sort grep { $_ ne $warper_value } @choice; |
|
0
|
|
|
|
|
|
|
585
|
|
|
|
|
|
|
|
586
|
0
|
|
|
|
|
|
$str .= "\t'" . $warper->location . "': Try "; |
587
|
|
|
|
|
|
|
|
588
|
0
|
0
|
|
|
|
|
my $a = $warper->{value_type} =~ /^[aeiou]/ ? 'an' : 'a'; |
589
|
|
|
|
|
|
|
|
590
|
0
|
0
|
|
|
|
|
$str .= |
591
|
|
|
|
|
|
|
@try |
592
|
|
|
|
|
|
|
? "'" . join( "' or '", @try ) . "' instead of " |
593
|
|
|
|
|
|
|
: "$a $warper->{value_type} value different from "; |
594
|
|
|
|
|
|
|
|
595
|
0
|
|
|
|
|
|
$str .= "'$warper_value'\n"; |
596
|
|
|
|
|
|
|
|
597
|
0
|
0
|
|
|
|
|
if ( defined $warper->{compute} ) { |
598
|
0
|
|
|
|
|
|
$str .= "\n\tHowever, '" . $warper->name . "' " . $warper->compute_info . "\n"; |
599
|
|
|
|
|
|
|
} |
600
|
|
|
|
|
|
|
} |
601
|
|
|
|
|
|
|
|
602
|
0
|
0
|
|
|
|
|
$str .= "Warp parameters:\n" . Data::Dumper->Dump( [ $self->{warp} ], ['warp'] ) |
603
|
|
|
|
|
|
|
if $logger->is_debug; |
604
|
|
|
|
|
|
|
|
605
|
0
|
|
|
|
|
|
return $str; |
606
|
|
|
|
|
|
|
} |
607
|
|
|
|
|
|
|
|
608
|
|
|
|
|
|
|
__PACKAGE__->meta->make_immutable; |
609
|
|
|
|
|
|
|
|
610
|
|
|
|
|
|
|
# ABSTRACT: Warp tree properties |
611
|
|
|
|
|
|
|
|
612
|
|
|
|
|
|
|
1; |
613
|
|
|
|
|
|
|
|
614
|
|
|
|
|
|
|
__END__ |
615
|
|
|
|
|
|
|
|
616
|
|
|
|
|
|
|
=pod |
617
|
|
|
|
|
|
|
|
618
|
|
|
|
|
|
|
=encoding UTF-8 |
619
|
|
|
|
|
|
|
|
620
|
|
|
|
|
|
|
=head1 NAME |
621
|
|
|
|
|
|
|
|
622
|
|
|
|
|
|
|
Config::Model::Warper - Warp tree properties |
623
|
|
|
|
|
|
|
|
624
|
|
|
|
|
|
|
=head1 VERSION |
625
|
|
|
|
|
|
|
|
626
|
|
|
|
|
|
|
version 2.153 |
627
|
|
|
|
|
|
|
|
628
|
|
|
|
|
|
|
=head1 SYNOPSIS |
629
|
|
|
|
|
|
|
|
630
|
|
|
|
|
|
|
# internal class |
631
|
|
|
|
|
|
|
|
632
|
|
|
|
|
|
|
=head1 DESCRIPTION |
633
|
|
|
|
|
|
|
|
634
|
|
|
|
|
|
|
Depending on the value of a warp master (In fact a L<Config::Model::Value> or a L<Config::Model::CheckList> object), |
635
|
|
|
|
|
|
|
this class changes the properties of a node (L<Config::Model::WarpedNode>), |
636
|
|
|
|
|
|
|
a hash (L<Config::Model::HashId>), a list (L<Config::Model::ListId>), |
637
|
|
|
|
|
|
|
a checklist (L<Config::Model::CheckList>) or another value. |
638
|
|
|
|
|
|
|
|
639
|
|
|
|
|
|
|
=head1 Warper and warped |
640
|
|
|
|
|
|
|
|
641
|
|
|
|
|
|
|
Warping an object means that the properties of the object is |
642
|
|
|
|
|
|
|
changed depending on the value of another object. |
643
|
|
|
|
|
|
|
|
644
|
|
|
|
|
|
|
The changed object is referred as the I<warped> object. |
645
|
|
|
|
|
|
|
|
646
|
|
|
|
|
|
|
The other object that holds the important value is referred as the |
647
|
|
|
|
|
|
|
I<warp master> or the I<warper> object. |
648
|
|
|
|
|
|
|
|
649
|
|
|
|
|
|
|
You can also set up several warp master for one warped object. This |
650
|
|
|
|
|
|
|
means that the properties of the warped object is changed |
651
|
|
|
|
|
|
|
according to a combination of values of the warp masters. |
652
|
|
|
|
|
|
|
|
653
|
|
|
|
|
|
|
=head1 Warp arguments |
654
|
|
|
|
|
|
|
|
655
|
|
|
|
|
|
|
Warp arguments are passed in a hash ref whose keys are C<follow> and |
656
|
|
|
|
|
|
|
and C<rules>: |
657
|
|
|
|
|
|
|
|
658
|
|
|
|
|
|
|
=head2 Warp follow argument |
659
|
|
|
|
|
|
|
|
660
|
|
|
|
|
|
|
L<Grab string|Config::Model::Role::Grab/grab> leading to the |
661
|
|
|
|
|
|
|
C<Config::Model::Value> or L<Config::Model::CheckList> warp master. E.g.: |
662
|
|
|
|
|
|
|
|
663
|
|
|
|
|
|
|
follow => '! tree_macro' |
664
|
|
|
|
|
|
|
|
665
|
|
|
|
|
|
|
In case of several warp master, C<follow> is set to an array ref |
666
|
|
|
|
|
|
|
of several L<grab string|Config::Model::Role::Grab/grab>: |
667
|
|
|
|
|
|
|
|
668
|
|
|
|
|
|
|
follow => [ '! macro1', '- macro2' ] |
669
|
|
|
|
|
|
|
|
670
|
|
|
|
|
|
|
You can also use named parameters: |
671
|
|
|
|
|
|
|
|
672
|
|
|
|
|
|
|
follow => { m1 => '! macro1', m2 => '- macro2' } |
673
|
|
|
|
|
|
|
|
674
|
|
|
|
|
|
|
Note: By design C<follow> argument of warper module is a plain path to keep |
675
|
|
|
|
|
|
|
warp mechanism (relatively) simple. C<follow> argument |
676
|
|
|
|
|
|
|
of L<Config::Model::ValueComputer> has more features and is documented |
677
|
|
|
|
|
|
|
L<there|Config::Model::ValueComputer/"Compute variables"> |
678
|
|
|
|
|
|
|
|
679
|
|
|
|
|
|
|
=head2 Warp rules argument |
680
|
|
|
|
|
|
|
|
681
|
|
|
|
|
|
|
String, hash ref or array ref that specify the warped object property |
682
|
|
|
|
|
|
|
changes. These rules specifies the actual property changes for the |
683
|
|
|
|
|
|
|
warped object depending on the value(s) of the warp master(s). |
684
|
|
|
|
|
|
|
|
685
|
|
|
|
|
|
|
E.g. for a simple case (rules is a hash ref) : |
686
|
|
|
|
|
|
|
|
687
|
|
|
|
|
|
|
follow => '! macro1' , |
688
|
|
|
|
|
|
|
rules => { A => { <effect when macro1 is A> }, |
689
|
|
|
|
|
|
|
B => { <effect when macro1 is B> } |
690
|
|
|
|
|
|
|
} |
691
|
|
|
|
|
|
|
|
692
|
|
|
|
|
|
|
In case of similar effects, you can use named parameters and |
693
|
|
|
|
|
|
|
a boolean expression to specify the effect. The first match |
694
|
|
|
|
|
|
|
is applied. In this case, rules is a list ref: |
695
|
|
|
|
|
|
|
|
696
|
|
|
|
|
|
|
follow => { m => '! macro1' } , |
697
|
|
|
|
|
|
|
rules => [ '$m eq "A"' => { <effect for macro1 == A> }, |
698
|
|
|
|
|
|
|
'$m eq "B" or $m eq"C "' => { <effect for macro1 == B|C > } |
699
|
|
|
|
|
|
|
] |
700
|
|
|
|
|
|
|
|
701
|
|
|
|
|
|
|
In case of several warp masters, C<follow> must use named parameters, and |
702
|
|
|
|
|
|
|
rules must use boolean expression: |
703
|
|
|
|
|
|
|
|
704
|
|
|
|
|
|
|
follow => { m1 => '! macro1', m2 => '- macro2' } , |
705
|
|
|
|
|
|
|
rules => [ |
706
|
|
|
|
|
|
|
'$m1 eq "A" && $m2 eq "C"' => { <effect for A C> }, |
707
|
|
|
|
|
|
|
'$m1 eq "A" && $m2 eq "D"' => { <effect for A D> }, |
708
|
|
|
|
|
|
|
'$m1 eq "B" && $m2 eq "C"' => { <effect for B C> }, |
709
|
|
|
|
|
|
|
'$m1 eq "B" && $m2 eq "D"' => { <effect for B D> }, |
710
|
|
|
|
|
|
|
] |
711
|
|
|
|
|
|
|
|
712
|
|
|
|
|
|
|
Of course some combinations of warp master values can have the same |
713
|
|
|
|
|
|
|
effect: |
714
|
|
|
|
|
|
|
|
715
|
|
|
|
|
|
|
follow => { m1 => '! macro1', m2 => '- macro2' } , |
716
|
|
|
|
|
|
|
rules => [ |
717
|
|
|
|
|
|
|
'$m1 eq "A" && $m2 eq "C"' => { <effect X> }, |
718
|
|
|
|
|
|
|
'$m1 eq "A" && $m2 eq "D"' => { <effect Y> }, |
719
|
|
|
|
|
|
|
'$m1 eq "B" && $m2 eq "C"' => { <effect Y> }, |
720
|
|
|
|
|
|
|
'$m1 eq "B" && $m2 eq "D"' => { <effect Y> }, |
721
|
|
|
|
|
|
|
] |
722
|
|
|
|
|
|
|
|
723
|
|
|
|
|
|
|
In this case, you can use different boolean expression to save typing: |
724
|
|
|
|
|
|
|
|
725
|
|
|
|
|
|
|
follow => { m1 => '! macro1', m2 => '- macro2' } , |
726
|
|
|
|
|
|
|
rules => [ |
727
|
|
|
|
|
|
|
'$m1 eq "A" && $m2 eq "C"' => { <effect X> }, |
728
|
|
|
|
|
|
|
'$m1 eq "A" && $m2 eq "D"' => { <effect Y> }, |
729
|
|
|
|
|
|
|
'$m1 eq "B" && ( $m2 eq "C" or $m2 eq "D") ' => { <effect Y> }, |
730
|
|
|
|
|
|
|
] |
731
|
|
|
|
|
|
|
|
732
|
|
|
|
|
|
|
Note that the boolean expression is sanitized and used in a Perl |
733
|
|
|
|
|
|
|
eval, so you can use most Perl syntax and regular expressions. |
734
|
|
|
|
|
|
|
|
735
|
|
|
|
|
|
|
Functions (like C<&foo>) are called like C<< $self->foo >> before evaluation |
736
|
|
|
|
|
|
|
of the boolean expression. |
737
|
|
|
|
|
|
|
|
738
|
|
|
|
|
|
|
The rules must be declared with a slightly different way when a |
739
|
|
|
|
|
|
|
check_list is used as a warp master: a check_list has not a simple |
740
|
|
|
|
|
|
|
value. The rule must check whether a value is checked or not amongs |
741
|
|
|
|
|
|
|
all the possible items of a check list. |
742
|
|
|
|
|
|
|
|
743
|
|
|
|
|
|
|
For example, let's say that C<$cl> in the rule below point to a check list whose |
744
|
|
|
|
|
|
|
items are C<A> and C<B>. The rule must verify if the item is set or not: |
745
|
|
|
|
|
|
|
|
746
|
|
|
|
|
|
|
rules => [ |
747
|
|
|
|
|
|
|
'$cl.is_set(A)' => { <effect when A is set> }, |
748
|
|
|
|
|
|
|
'$cl.is_set(B)' => { <effect when B is set> }, |
749
|
|
|
|
|
|
|
# can be combined |
750
|
|
|
|
|
|
|
'$cl.is_set(B) and $cl.is_set(A)' => { <effect when A and B are set> }, |
751
|
|
|
|
|
|
|
], |
752
|
|
|
|
|
|
|
|
753
|
|
|
|
|
|
|
With this feature, you can control with a check list whether some element must |
754
|
|
|
|
|
|
|
be shown or not (assuming C<FooClass> and C<BarClass> classes are declared): |
755
|
|
|
|
|
|
|
|
756
|
|
|
|
|
|
|
element => [ |
757
|
|
|
|
|
|
|
# warp master |
758
|
|
|
|
|
|
|
my_check_list => { |
759
|
|
|
|
|
|
|
type => 'check_list', |
760
|
|
|
|
|
|
|
choice => ['has_foo','has_bar'] |
761
|
|
|
|
|
|
|
}, |
762
|
|
|
|
|
|
|
# controlled element that show up only when has_foo is set |
763
|
|
|
|
|
|
|
foo => { |
764
|
|
|
|
|
|
|
type => 'warped_node', |
765
|
|
|
|
|
|
|
level => 'hidden', |
766
|
|
|
|
|
|
|
config_class_name => 'FooClass', |
767
|
|
|
|
|
|
|
follow => { |
768
|
|
|
|
|
|
|
selected => '- my_check_list' |
769
|
|
|
|
|
|
|
}, |
770
|
|
|
|
|
|
|
'rules' => [ |
771
|
|
|
|
|
|
|
'$selected.is_set(has_foo)' => { |
772
|
|
|
|
|
|
|
level => 'normal' |
773
|
|
|
|
|
|
|
} |
774
|
|
|
|
|
|
|
] |
775
|
|
|
|
|
|
|
}, |
776
|
|
|
|
|
|
|
# controlled element that show up only when has_bar is set |
777
|
|
|
|
|
|
|
bar => { |
778
|
|
|
|
|
|
|
type => 'warped_node', |
779
|
|
|
|
|
|
|
level => 'hidden', |
780
|
|
|
|
|
|
|
config_class_name => 'BarClass', |
781
|
|
|
|
|
|
|
follow => { |
782
|
|
|
|
|
|
|
selected => '- my_check_list' |
783
|
|
|
|
|
|
|
}, |
784
|
|
|
|
|
|
|
'rules' => [ |
785
|
|
|
|
|
|
|
'$selected.is_set(has_bar)' => { |
786
|
|
|
|
|
|
|
level => 'normal' |
787
|
|
|
|
|
|
|
} |
788
|
|
|
|
|
|
|
] |
789
|
|
|
|
|
|
|
} |
790
|
|
|
|
|
|
|
] |
791
|
|
|
|
|
|
|
|
792
|
|
|
|
|
|
|
=head1 Methods |
793
|
|
|
|
|
|
|
|
794
|
|
|
|
|
|
|
=head2 warp_error |
795
|
|
|
|
|
|
|
|
796
|
|
|
|
|
|
|
This method returns a string describing: |
797
|
|
|
|
|
|
|
|
798
|
|
|
|
|
|
|
=over |
799
|
|
|
|
|
|
|
|
800
|
|
|
|
|
|
|
=item * |
801
|
|
|
|
|
|
|
|
802
|
|
|
|
|
|
|
The location(s) of the warp master |
803
|
|
|
|
|
|
|
|
804
|
|
|
|
|
|
|
=item * |
805
|
|
|
|
|
|
|
|
806
|
|
|
|
|
|
|
The current value(s) of the warp master(s) |
807
|
|
|
|
|
|
|
|
808
|
|
|
|
|
|
|
=item * |
809
|
|
|
|
|
|
|
|
810
|
|
|
|
|
|
|
The other values accepted by the warp master that can be tried (if the |
811
|
|
|
|
|
|
|
warp master is an enumerated type) |
812
|
|
|
|
|
|
|
|
813
|
|
|
|
|
|
|
=back |
814
|
|
|
|
|
|
|
|
815
|
|
|
|
|
|
|
=head1 How does this work ? |
816
|
|
|
|
|
|
|
|
817
|
|
|
|
|
|
|
=over |
818
|
|
|
|
|
|
|
|
819
|
|
|
|
|
|
|
=item Registration |
820
|
|
|
|
|
|
|
|
821
|
|
|
|
|
|
|
=over |
822
|
|
|
|
|
|
|
|
823
|
|
|
|
|
|
|
=item * |
824
|
|
|
|
|
|
|
|
825
|
|
|
|
|
|
|
When a warped object is created, the constructor registers to the |
826
|
|
|
|
|
|
|
warp masters. The warp master are found by using the special string |
827
|
|
|
|
|
|
|
passed to the C<follow> parameter. As explained in |
828
|
|
|
|
|
|
|
L<grab method|Config::Model::Role::Grab/grab>, |
829
|
|
|
|
|
|
|
the string provides the location of the warp master in the |
830
|
|
|
|
|
|
|
configuration tree using a symbolic form. |
831
|
|
|
|
|
|
|
|
832
|
|
|
|
|
|
|
=item * |
833
|
|
|
|
|
|
|
|
834
|
|
|
|
|
|
|
Then the warped object retrieve the value(s) of the warp master(s) |
835
|
|
|
|
|
|
|
|
836
|
|
|
|
|
|
|
=item * |
837
|
|
|
|
|
|
|
|
838
|
|
|
|
|
|
|
Then the warped object warps itself using the above |
839
|
|
|
|
|
|
|
value(s). Depending on these value(s), the properties of the warped |
840
|
|
|
|
|
|
|
object are modified. |
841
|
|
|
|
|
|
|
|
842
|
|
|
|
|
|
|
=back |
843
|
|
|
|
|
|
|
|
844
|
|
|
|
|
|
|
=item Master update |
845
|
|
|
|
|
|
|
|
846
|
|
|
|
|
|
|
=over |
847
|
|
|
|
|
|
|
|
848
|
|
|
|
|
|
|
=item * |
849
|
|
|
|
|
|
|
|
850
|
|
|
|
|
|
|
When a warp master value is updated, the warp master calls I<all> |
851
|
|
|
|
|
|
|
its warped object and pass them the new master value. |
852
|
|
|
|
|
|
|
|
853
|
|
|
|
|
|
|
=item * |
854
|
|
|
|
|
|
|
|
855
|
|
|
|
|
|
|
Then each warped object modifies properties according to the |
856
|
|
|
|
|
|
|
new warp master value. |
857
|
|
|
|
|
|
|
|
858
|
|
|
|
|
|
|
=back |
859
|
|
|
|
|
|
|
|
860
|
|
|
|
|
|
|
=back |
861
|
|
|
|
|
|
|
|
862
|
|
|
|
|
|
|
=head1 AUTHOR |
863
|
|
|
|
|
|
|
|
864
|
|
|
|
|
|
|
Dominique Dumont, (ddumont at cpan dot org) |
865
|
|
|
|
|
|
|
|
866
|
|
|
|
|
|
|
=head1 SEE ALSO |
867
|
|
|
|
|
|
|
|
868
|
|
|
|
|
|
|
L<Config::Model::AnyThing>, |
869
|
|
|
|
|
|
|
L<Config::Model::HashId>, |
870
|
|
|
|
|
|
|
L<Config::Model::ListId>, |
871
|
|
|
|
|
|
|
L<Config::Model::WarpedNode>, |
872
|
|
|
|
|
|
|
L<Config::Model::Value> |
873
|
|
|
|
|
|
|
|
874
|
|
|
|
|
|
|
=head1 AUTHOR |
875
|
|
|
|
|
|
|
|
876
|
|
|
|
|
|
|
Dominique Dumont |
877
|
|
|
|
|
|
|
|
878
|
|
|
|
|
|
|
=head1 COPYRIGHT AND LICENSE |
879
|
|
|
|
|
|
|
|
880
|
|
|
|
|
|
|
This software is Copyright (c) 2005-2022 by Dominique Dumont. |
881
|
|
|
|
|
|
|
|
882
|
|
|
|
|
|
|
This is free software, licensed under: |
883
|
|
|
|
|
|
|
|
884
|
|
|
|
|
|
|
The GNU Lesser General Public License, Version 2.1, February 1999 |
885
|
|
|
|
|
|
|
|
886
|
|
|
|
|
|
|
=cut |