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
|
|
|
|
|
|
|
|
11
|
|
|
|
|
|
|
use Mouse; |
12
|
22
|
|
|
22
|
|
708
|
|
|
22
|
|
|
|
|
41
|
|
|
22
|
|
|
|
|
190
|
|
13
|
|
|
|
|
|
|
use Carp qw(cluck croak); |
14
|
22
|
|
|
22
|
|
9435
|
|
|
22
|
|
|
|
|
42
|
|
|
22
|
|
|
|
|
1267
|
|
15
|
|
|
|
|
|
|
use Config::Model::Exception; |
16
|
22
|
|
|
22
|
|
125
|
use Config::Model::Warper; |
|
22
|
|
|
|
|
43
|
|
|
22
|
|
|
|
|
436
|
|
17
|
22
|
|
|
22
|
|
108
|
use Data::Dumper (); |
|
22
|
|
|
|
|
43
|
|
|
22
|
|
|
|
|
444
|
|
18
|
22
|
|
|
22
|
|
100
|
use Log::Log4perl qw(get_logger :levels); |
|
22
|
|
|
|
|
40
|
|
|
22
|
|
|
|
|
466
|
|
19
|
22
|
|
|
22
|
|
131
|
use Storable qw/dclone/; |
|
22
|
|
|
|
|
41
|
|
|
22
|
|
|
|
|
205
|
|
20
|
22
|
|
|
22
|
|
2941
|
use Scalar::Util qw/weaken/; |
|
22
|
|
|
|
|
42
|
|
|
22
|
|
|
|
|
1028
|
|
21
|
22
|
|
|
22
|
|
141
|
|
|
22
|
|
|
|
|
62
|
|
|
22
|
|
|
|
|
8835
|
|
22
|
|
|
|
|
|
|
extends qw/Config::Model::AnyThing/; |
23
|
|
|
|
|
|
|
|
24
|
|
|
|
|
|
|
with "Config::Model::Role::NodeLoader"; |
25
|
|
|
|
|
|
|
with "Config::Model::Role::Grab"; |
26
|
|
|
|
|
|
|
|
27
|
|
|
|
|
|
|
my $logger = get_logger("Tree::Node::Warped"); |
28
|
|
|
|
|
|
|
|
29
|
|
|
|
|
|
|
# don't authorize to warp 'morph' parameter as it may lead to |
30
|
|
|
|
|
|
|
# difficult maintenance |
31
|
|
|
|
|
|
|
|
32
|
|
|
|
|
|
|
# status is not warpable either as an obsolete parameter must stay |
33
|
|
|
|
|
|
|
# obsolete |
34
|
|
|
|
|
|
|
|
35
|
|
|
|
|
|
|
my @allowed_warp_params = qw/config_class_name level gist/; |
36
|
|
|
|
|
|
|
|
37
|
|
|
|
|
|
|
has 'backup' => ( is => 'rw', isa => 'HashRef', default => sub { {}; } ); |
38
|
|
|
|
|
|
|
|
39
|
|
|
|
|
|
|
has 'warp' => ( is => 'rw', isa => 'HashRef', default => sub { {}; }); |
40
|
|
|
|
|
|
|
has 'morph' => ( is => 'ro', isa => 'Bool', default => 0 ); |
41
|
|
|
|
|
|
|
|
42
|
|
|
|
|
|
|
has warper => ( is => 'rw', isa => 'Config::Model::Warper' ); |
43
|
|
|
|
|
|
|
|
44
|
|
|
|
|
|
|
my @backup_list = @allowed_warp_params; |
45
|
|
|
|
|
|
|
|
46
|
|
|
|
|
|
|
around BUILDARGS => sub { |
47
|
|
|
|
|
|
|
my $orig = shift; |
48
|
|
|
|
|
|
|
my $class = shift; |
49
|
|
|
|
|
|
|
my %args = @_; |
50
|
|
|
|
|
|
|
my %h = map { ( $_ => $args{$_} ); } grep { defined $args{$_} } @backup_list; |
51
|
|
|
|
|
|
|
return $class->$orig( backup => dclone( \%h ), @_ ); |
52
|
|
|
|
|
|
|
}; |
53
|
|
|
|
|
|
|
|
54
|
|
|
|
|
|
|
my $self = shift; |
55
|
|
|
|
|
|
|
|
56
|
129
|
|
|
129
|
1
|
363
|
# WarpedNode registers this object in a Value object (the |
57
|
|
|
|
|
|
|
# warper). When the warper gets a new value, it modifies the |
58
|
|
|
|
|
|
|
# WarpedNode according to the data passed by the user. |
59
|
|
|
|
|
|
|
|
60
|
|
|
|
|
|
|
my $warp_info = $self->warp; |
61
|
|
|
|
|
|
|
$warp_info->{follow} //= {}; |
62
|
129
|
|
|
|
|
445
|
$warp_info->{rules} //= []; |
63
|
129
|
|
50
|
|
|
481
|
my $w = Config::Model::Warper->new( |
64
|
129
|
|
50
|
|
|
303
|
warped_object => $self, |
65
|
129
|
|
|
|
|
1970
|
%$warp_info, |
66
|
|
|
|
|
|
|
allowed => \@allowed_warp_params |
67
|
|
|
|
|
|
|
); |
68
|
|
|
|
|
|
|
|
69
|
|
|
|
|
|
|
$self->warper($w); |
70
|
|
|
|
|
|
|
return $self; |
71
|
129
|
|
|
|
|
1144
|
} |
72
|
129
|
|
|
|
|
1222
|
|
73
|
|
|
|
|
|
|
my $self = shift; |
74
|
|
|
|
|
|
|
return $self->parent->config_model; |
75
|
|
|
|
|
|
|
} |
76
|
340
|
|
|
340
|
0
|
685
|
|
77
|
340
|
|
|
|
|
1905
|
# Forward selected methods (See man perltootc) |
78
|
|
|
|
|
|
|
foreach my $method ( |
79
|
|
|
|
|
|
|
qw/fetch_element config_class_name copy_from get_element_name |
80
|
|
|
|
|
|
|
get_info fetch_gist has_element is_element_available element_type load |
81
|
|
|
|
|
|
|
fetch_element_value get_type get_cargo_type dump_tree needs_save |
82
|
|
|
|
|
|
|
describe get_help get_help_as_text children get set accept_regexp/ |
83
|
|
|
|
|
|
|
) { |
84
|
|
|
|
|
|
|
# to register new methods in package |
85
|
|
|
|
|
|
|
no strict "refs"; ## no critic TestingAndDebugging::ProhibitNoStrict |
86
|
|
|
|
|
|
|
|
87
|
|
|
|
|
|
|
*$method = sub { |
88
|
22
|
|
|
22
|
|
156
|
my $self = shift; |
|
22
|
|
|
|
|
61
|
|
|
22
|
|
|
|
|
23701
|
|
89
|
|
|
|
|
|
|
|
90
|
|
|
|
|
|
|
if ($self->check) { |
91
|
1423
|
|
|
1423
|
|
2123
|
return $self->{data}->$method(@_); |
|
|
|
|
1418
|
|
|
|
92
|
|
|
|
|
|
|
} |
93
|
1423
|
100
|
|
|
|
2712
|
|
94
|
1422
|
|
|
|
|
4784
|
# return undef if no class was warped in |
95
|
|
|
|
|
|
|
return ; |
96
|
|
|
|
|
|
|
}; |
97
|
|
|
|
|
|
|
} |
98
|
1
|
|
|
|
|
5
|
|
99
|
|
|
|
|
|
|
my $self = shift; |
100
|
|
|
|
|
|
|
return $self->location; |
101
|
|
|
|
|
|
|
} |
102
|
|
|
|
|
|
|
|
103
|
2391
|
|
|
2391
|
1
|
3070
|
my $self = shift; |
104
|
2391
|
|
|
|
|
10813
|
return defined $self->{data} ? 1 : 0; |
105
|
|
|
|
|
|
|
} |
106
|
|
|
|
|
|
|
|
107
|
|
|
|
|
|
|
my $self = shift; |
108
|
2
|
|
|
2
|
1
|
4
|
$self->check; |
109
|
2
|
50
|
|
|
|
11
|
return $self->{data}; # might be undef |
110
|
|
|
|
|
|
|
} |
111
|
|
|
|
|
|
|
|
112
|
|
|
|
|
|
|
my $self = shift; |
113
|
261
|
|
|
261
|
1
|
474
|
my $check = shift || 'yes '; |
114
|
261
|
|
|
|
|
850
|
|
115
|
261
|
|
|
|
|
570
|
# must croak if element is not available |
116
|
|
|
|
|
|
|
if ( not defined $self->{data} ) { |
117
|
|
|
|
|
|
|
|
118
|
|
|
|
|
|
|
# a node can be retrieved either for a store operation or for |
119
|
1684
|
|
|
1684
|
0
|
2266
|
# a fetch. |
120
|
1684
|
|
50
|
|
|
4511
|
if ( $check eq 'yes' ) { |
121
|
|
|
|
|
|
|
Config::Model::Exception::User->throw( |
122
|
|
|
|
|
|
|
object => $self, |
123
|
1684
|
100
|
|
|
|
3700
|
message => "Object '$self->{element_name}' is not accessible.\n\t" |
124
|
|
|
|
|
|
|
. $self->warp_error |
125
|
|
|
|
|
|
|
); |
126
|
|
|
|
|
|
|
} |
127
|
1
|
50
|
|
|
|
3
|
else { |
128
|
0
|
|
|
|
|
0
|
return 0; |
129
|
|
|
|
|
|
|
} |
130
|
|
|
|
|
|
|
} |
131
|
|
|
|
|
|
|
return 1; |
132
|
|
|
|
|
|
|
} |
133
|
|
|
|
|
|
|
|
134
|
|
|
|
|
|
|
my $self = shift; |
135
|
1
|
|
|
|
|
50
|
|
136
|
|
|
|
|
|
|
my %args = ( %{ $self->backup }, @_ ); |
137
|
|
|
|
|
|
|
|
138
|
1683
|
|
|
|
|
3061
|
# mega cleanup |
139
|
|
|
|
|
|
|
for (@allowed_warp_params) { delete $self->{$_} } |
140
|
|
|
|
|
|
|
|
141
|
|
|
|
|
|
|
$logger->trace( $self->name . " set_properties called with ", |
142
|
174
|
|
|
174
|
0
|
355
|
Data::Dumper->Dump( [ \%args ], ['set_properties_args'] ) ); |
143
|
|
|
|
|
|
|
|
144
|
174
|
|
|
|
|
264
|
my $config_class_name = delete $args{config_class_name}; |
|
174
|
|
|
|
|
797
|
|
145
|
|
|
|
|
|
|
my $node_class = delete $args{class} || 'Config::Model::Node'; |
146
|
|
|
|
|
|
|
|
147
|
174
|
|
|
|
|
445
|
my @prop_args = ( qw/property level element/, $self->element_name ); |
|
522
|
|
|
|
|
934
|
|
148
|
|
|
|
|
|
|
|
149
|
174
|
|
|
|
|
645
|
my $original_level = $self->config_model->get_element_property( |
150
|
|
|
|
|
|
|
class => $self->parent->config_class_name, |
151
|
|
|
|
|
|
|
@prop_args, |
152
|
174
|
|
|
|
|
7724
|
); |
153
|
174
|
|
50
|
|
|
743
|
|
154
|
|
|
|
|
|
|
my $next_level = |
155
|
174
|
|
|
|
|
726
|
defined $args{level} ? $args{level} |
156
|
|
|
|
|
|
|
: defined $config_class_name ? $original_level |
157
|
174
|
|
|
|
|
518
|
: 'hidden'; |
158
|
|
|
|
|
|
|
|
159
|
|
|
|
|
|
|
$self->parent->set_element_property( @prop_args, value => $next_level ) |
160
|
|
|
|
|
|
|
unless defined $self->index_value; |
161
|
|
|
|
|
|
|
|
162
|
|
|
|
|
|
|
unless ( defined $config_class_name ) { |
163
|
|
|
|
|
|
|
$self->clear; |
164
|
174
|
100
|
|
|
|
2299
|
return; |
|
|
100
|
|
|
|
|
|
165
|
|
|
|
|
|
|
} |
166
|
|
|
|
|
|
|
|
167
|
174
|
100
|
|
|
|
1255
|
my @args; |
168
|
|
|
|
|
|
|
( $config_class_name, @args ) = @$config_class_name |
169
|
|
|
|
|
|
|
if ref $config_class_name; |
170
|
174
|
100
|
|
|
|
410
|
|
171
|
8
|
|
|
|
|
22
|
# check if some action is needed (ie. create or morph node) |
172
|
8
|
|
|
|
|
34
|
return |
173
|
|
|
|
|
|
|
if defined $self->{config_class_name} |
174
|
|
|
|
|
|
|
and $self->{config_class_name} eq $config_class_name; |
175
|
166
|
|
|
|
|
254
|
|
176
|
166
|
100
|
|
|
|
396
|
my $old_object = $self->{data}; |
177
|
|
|
|
|
|
|
my $old_config_class_name = $self->{config_class_name}; |
178
|
|
|
|
|
|
|
|
179
|
|
|
|
|
|
|
# create a new object from scratch |
180
|
|
|
|
|
|
|
my $new_object = $self->create_node( $config_class_name, @args ); |
181
|
|
|
|
|
|
|
|
182
|
166
|
50
|
33
|
|
|
557
|
$self->{config_class_name} = $config_class_name; |
183
|
|
|
|
|
|
|
$self->{data} = $new_object; |
184
|
166
|
|
|
|
|
285
|
|
185
|
166
|
|
|
|
|
289
|
if ( defined $old_object and $self->{morph} ) { |
186
|
|
|
|
|
|
|
|
187
|
|
|
|
|
|
|
# there an old object that we need to translate |
188
|
166
|
|
|
|
|
538
|
$logger->debug( "WarpedNode: morphing ", $old_object->name, " to ", $new_object->name ) |
189
|
|
|
|
|
|
|
if $logger->is_debug; |
190
|
166
|
|
|
|
|
399
|
|
191
|
166
|
|
|
|
|
339
|
$new_object->copy_from( from => $old_object, check => 'skip' ); |
192
|
|
|
|
|
|
|
} |
193
|
166
|
100
|
100
|
|
|
489
|
|
194
|
|
|
|
|
|
|
# bringing a new object does not really modify the content of the config tree. |
195
|
|
|
|
|
|
|
# only changes underneath changes the tree. And these changes below triggers |
196
|
24
|
50
|
|
|
|
72
|
# their own change notif. So there's no need to call notify_change when transitioning |
197
|
|
|
|
|
|
|
# from an undef object into a real object. On the other hand, warping out an object does |
198
|
|
|
|
|
|
|
# NOT trigger notify_changes from below. So notify_change must be called |
199
|
24
|
|
|
|
|
187
|
if ( defined $old_object and $old_config_class_name) { |
200
|
|
|
|
|
|
|
my $from = $old_config_class_name ; |
201
|
|
|
|
|
|
|
my $to = $config_class_name // '<undef>'; |
202
|
|
|
|
|
|
|
$self->notify_change( note => "warped node from $from to $to" ); |
203
|
|
|
|
|
|
|
} |
204
|
|
|
|
|
|
|
|
205
|
|
|
|
|
|
|
# need to call trigger on all registered objects only after all is setup |
206
|
|
|
|
|
|
|
$self->trigger_warp; |
207
|
166
|
50
|
66
|
|
|
551
|
} |
208
|
0
|
|
|
|
|
0
|
|
209
|
0
|
|
0
|
|
|
0
|
my $self = shift; |
210
|
0
|
|
|
|
|
0
|
my $config_class_name = shift; |
211
|
|
|
|
|
|
|
|
212
|
|
|
|
|
|
|
my @args = ( |
213
|
|
|
|
|
|
|
config_class_name => $config_class_name, |
214
|
166
|
|
|
|
|
551
|
instance => $self->{instance}, |
215
|
|
|
|
|
|
|
element_name => $self->{element_name}, |
216
|
|
|
|
|
|
|
parent => $self->parent, |
217
|
|
|
|
|
|
|
container => $self->container, |
218
|
166
|
|
|
166
|
0
|
260
|
); |
219
|
166
|
|
|
|
|
257
|
|
220
|
|
|
|
|
|
|
push @args, index_value => $self->index_value if defined $self->index_value; |
221
|
|
|
|
|
|
|
|
222
|
|
|
|
|
|
|
return $self->load_node(@args); |
223
|
|
|
|
|
|
|
} |
224
|
|
|
|
|
|
|
|
225
|
166
|
|
|
|
|
1007
|
my $self = shift; |
226
|
|
|
|
|
|
|
delete $self->{data}; |
227
|
|
|
|
|
|
|
} |
228
|
|
|
|
|
|
|
|
229
|
166
|
100
|
|
|
|
516
|
my $self = shift; |
230
|
|
|
|
|
|
|
my %args = @_ > 1 ? @_ : ( data => shift ); |
231
|
166
|
|
|
|
|
793
|
my $data = $args{data}; |
232
|
|
|
|
|
|
|
my $check = $self->_check_check( $args{check} ); |
233
|
|
|
|
|
|
|
|
234
|
|
|
|
|
|
|
if ( ref($data) ne 'HASH' ) { |
235
|
8
|
|
|
8
|
0
|
19
|
Config::Model::Exception::LoadData->throw( |
236
|
8
|
|
|
|
|
83
|
object => $self, |
237
|
|
|
|
|
|
|
message => "load_data called with non hash ref arg", |
238
|
|
|
|
|
|
|
wrong_data => $data, |
239
|
|
|
|
|
|
|
); |
240
|
4
|
|
|
4
|
1
|
9
|
} |
241
|
4
|
50
|
|
|
|
21
|
|
242
|
4
|
|
|
|
|
8
|
$self->get_actual_node->load_data(%args); |
243
|
4
|
|
|
|
|
19
|
|
244
|
|
|
|
|
|
|
} |
245
|
4
|
50
|
|
|
|
16
|
|
246
|
0
|
|
|
|
|
0
|
my $self = shift; |
247
|
|
|
|
|
|
|
$self->get_actual_node->is_auto_write_for_type(@_); |
248
|
|
|
|
|
|
|
} |
249
|
|
|
|
|
|
|
|
250
|
|
|
|
|
|
|
# register warper that goes through this path when looking for warp master value |
251
|
|
|
|
|
|
|
my ( $self, $warped, $w_idx ) = @_; |
252
|
|
|
|
|
|
|
|
253
|
4
|
|
|
|
|
14
|
$logger->debug( "WarpedNode: " . $self->name, " registered " . $warped->name ); |
254
|
|
|
|
|
|
|
|
255
|
|
|
|
|
|
|
# weaken only applies to the passed reference, and there's no way |
256
|
|
|
|
|
|
|
# to duplicate a weak ref. Only a strong ref is created. See |
257
|
|
|
|
|
|
|
# qw(weaken) module for weaken() |
258
|
2
|
|
|
2
|
0
|
4
|
my @tmp = ( $warped, $w_idx ); |
259
|
2
|
|
|
|
|
8
|
weaken( $tmp[0] ); |
260
|
|
|
|
|
|
|
push @{ $self->{warp_these_objects} }, \@tmp; |
261
|
|
|
|
|
|
|
} |
262
|
|
|
|
|
|
|
|
263
|
|
|
|
|
|
|
my $self = shift; |
264
|
124
|
|
|
124
|
0
|
291
|
|
265
|
|
|
|
|
|
|
# warp_these_objects is modified by the calls below, so this copy |
266
|
124
|
|
|
|
|
332
|
# must be done before the loop |
267
|
|
|
|
|
|
|
my @list = @{ $self->{warp_these_objects} || [] }; |
268
|
|
|
|
|
|
|
|
269
|
|
|
|
|
|
|
foreach my $ref (@list) { |
270
|
|
|
|
|
|
|
my ( $warped, $warp_index ) = @$ref; |
271
|
124
|
|
|
|
|
971
|
next unless defined $warped; # $warped is a weak ref and may vanish |
272
|
124
|
|
|
|
|
560
|
|
273
|
124
|
|
|
|
|
231
|
# pure warp of object |
|
124
|
|
|
|
|
553
|
|
274
|
|
|
|
|
|
|
$logger->debug( "node trigger_warp: from '", |
275
|
|
|
|
|
|
|
$self->name, "' warping '", $warped->name, "'" ); |
276
|
|
|
|
|
|
|
|
277
|
166
|
|
|
166
|
0
|
285
|
# FIXME: this does not trigger new registration (or removal thereof)... |
278
|
|
|
|
|
|
|
$warped->refresh_affected_registrations( $self->location ); |
279
|
|
|
|
|
|
|
|
280
|
|
|
|
|
|
|
#$warped->refresh_values_from_master ; |
281
|
166
|
100
|
|
|
|
277
|
$warped->do_warp; |
|
166
|
|
|
|
|
2571
|
|
282
|
|
|
|
|
|
|
$logger->debug( "node trigger_warp: from '", |
283
|
166
|
|
|
|
|
2185
|
$self->name, "' warping '", $warped->name, "' done" ); |
284
|
7
|
|
|
|
|
44
|
} |
285
|
7
|
50
|
|
|
|
21
|
} |
286
|
|
|
|
|
|
|
|
287
|
|
|
|
|
|
|
# FIXME: should we un-register ??? |
288
|
7
|
|
|
|
|
19
|
|
289
|
|
|
|
|
|
|
1; |
290
|
|
|
|
|
|
|
|
291
|
|
|
|
|
|
|
# ABSTRACT: Node that change config class properties |
292
|
7
|
|
|
|
|
417
|
|
293
|
|
|
|
|
|
|
|
294
|
|
|
|
|
|
|
=pod |
295
|
7
|
|
|
|
|
34
|
|
296
|
7
|
|
|
|
|
24
|
=encoding UTF-8 |
297
|
|
|
|
|
|
|
|
298
|
|
|
|
|
|
|
=head1 NAME |
299
|
|
|
|
|
|
|
|
300
|
|
|
|
|
|
|
Config::Model::WarpedNode - Node that change config class properties |
301
|
|
|
|
|
|
|
|
302
|
|
|
|
|
|
|
=head1 VERSION |
303
|
|
|
|
|
|
|
|
304
|
|
|
|
|
|
|
version 2.151 |
305
|
|
|
|
|
|
|
|
306
|
|
|
|
|
|
|
=head1 SYNOPSIS |
307
|
|
|
|
|
|
|
|
308
|
|
|
|
|
|
|
use Config::Model; |
309
|
|
|
|
|
|
|
|
310
|
|
|
|
|
|
|
my $model = Config::Model->new; |
311
|
|
|
|
|
|
|
foreach (qw/X Y/) { |
312
|
|
|
|
|
|
|
$model->create_config_class( |
313
|
|
|
|
|
|
|
name => "Class$_", |
314
|
|
|
|
|
|
|
element => [ foo => {qw/type leaf value_type string/} ] |
315
|
|
|
|
|
|
|
); |
316
|
|
|
|
|
|
|
} |
317
|
|
|
|
|
|
|
$model->create_config_class( |
318
|
|
|
|
|
|
|
name => "MyClass", |
319
|
|
|
|
|
|
|
|
320
|
|
|
|
|
|
|
element => [ |
321
|
|
|
|
|
|
|
master_switch => { |
322
|
|
|
|
|
|
|
type => 'leaf', |
323
|
|
|
|
|
|
|
value_type => 'enum', |
324
|
|
|
|
|
|
|
choice => [qw/cX cY/] |
325
|
|
|
|
|
|
|
}, |
326
|
|
|
|
|
|
|
|
327
|
|
|
|
|
|
|
'a_warped_node' => { |
328
|
|
|
|
|
|
|
type => 'warped_node', |
329
|
|
|
|
|
|
|
warp => } |
330
|
|
|
|
|
|
|
follow => { ms => '! master_switch' }, |
331
|
|
|
|
|
|
|
rules => [ |
332
|
|
|
|
|
|
|
'$ms eq "cX"' => { config_class_name => 'ClassX' }, |
333
|
|
|
|
|
|
|
'$ms eq "cY"' => { config_class_name => 'ClassY' }, |
334
|
|
|
|
|
|
|
] |
335
|
|
|
|
|
|
|
} |
336
|
|
|
|
|
|
|
}, |
337
|
|
|
|
|
|
|
], |
338
|
|
|
|
|
|
|
); |
339
|
|
|
|
|
|
|
|
340
|
|
|
|
|
|
|
my $inst = $model->instance(root_class_name => 'MyClass' ); |
341
|
|
|
|
|
|
|
my $root = $inst->config_root ; |
342
|
|
|
|
|
|
|
|
343
|
|
|
|
|
|
|
print "Visible elements: ",join(' ',$root->get_element_name),"\n" ; |
344
|
|
|
|
|
|
|
# Visible elements: master_switch |
345
|
|
|
|
|
|
|
|
346
|
|
|
|
|
|
|
$root->load( steps => 'master_switch=cX' ); |
347
|
|
|
|
|
|
|
print "Visible elements: ",join(' ',$root->get_element_name),"\n" ; |
348
|
|
|
|
|
|
|
# Visible elements: master_switch a_warped_node |
349
|
|
|
|
|
|
|
|
350
|
|
|
|
|
|
|
my $node = $root->grab('a_warped_node') ; |
351
|
|
|
|
|
|
|
print "a_warped_node class: ",$node->config_class_name,"\n" ; |
352
|
|
|
|
|
|
|
# a_warped_node class: ClassX |
353
|
|
|
|
|
|
|
|
354
|
|
|
|
|
|
|
$root->load( steps => 'master_switch=cY' ); |
355
|
|
|
|
|
|
|
print "a_warped_node class: ",$node->config_class_name,"\n" ; |
356
|
|
|
|
|
|
|
# a_warped_node class: ClassY |
357
|
|
|
|
|
|
|
|
358
|
|
|
|
|
|
|
=head1 DESCRIPTION |
359
|
|
|
|
|
|
|
|
360
|
|
|
|
|
|
|
This class provides a way to change dynamically the configuration |
361
|
|
|
|
|
|
|
class (or some other properties) of a node. The changes are done |
362
|
|
|
|
|
|
|
according to the model declaration. |
363
|
|
|
|
|
|
|
|
364
|
|
|
|
|
|
|
This declaration specifies one (or several) leaf in the |
365
|
|
|
|
|
|
|
configuration tree that triggers the actual property change of the |
366
|
|
|
|
|
|
|
warped node. This leaf is also referred as I<warp master>. |
367
|
|
|
|
|
|
|
|
368
|
|
|
|
|
|
|
When the warp master(s) value(s) changes, C<WarpedNode> creates an instance |
369
|
|
|
|
|
|
|
of the new class required by the warp master. |
370
|
|
|
|
|
|
|
|
371
|
|
|
|
|
|
|
If the morph parameter is set, the values held by the old object are |
372
|
|
|
|
|
|
|
(if possible) copied to the new instance of the object using |
373
|
|
|
|
|
|
|
L<copy_from|Config::Model::Node/"copy_from ( another_node_object )"> |
374
|
|
|
|
|
|
|
method. |
375
|
|
|
|
|
|
|
|
376
|
|
|
|
|
|
|
Warped node can alter the following properties: |
377
|
|
|
|
|
|
|
|
378
|
|
|
|
|
|
|
config_class_name |
379
|
|
|
|
|
|
|
level |
380
|
|
|
|
|
|
|
|
381
|
|
|
|
|
|
|
=head1 Constructor |
382
|
|
|
|
|
|
|
|
383
|
|
|
|
|
|
|
C<WarpedNode> should not be created directly. |
384
|
|
|
|
|
|
|
|
385
|
|
|
|
|
|
|
=head1 Warped node model declaration |
386
|
|
|
|
|
|
|
|
387
|
|
|
|
|
|
|
=head2 Parameter overview |
388
|
|
|
|
|
|
|
|
389
|
|
|
|
|
|
|
A warped node must be declared with the following parameters: |
390
|
|
|
|
|
|
|
|
391
|
|
|
|
|
|
|
=over |
392
|
|
|
|
|
|
|
|
393
|
|
|
|
|
|
|
=item type |
394
|
|
|
|
|
|
|
|
395
|
|
|
|
|
|
|
Always set to C<warped_node>. |
396
|
|
|
|
|
|
|
|
397
|
|
|
|
|
|
|
=item follow |
398
|
|
|
|
|
|
|
|
399
|
|
|
|
|
|
|
L<Grab string|Config::Model::Role::Grab/grab"> leading to the |
400
|
|
|
|
|
|
|
C<Config::Model::Value> warp master. |
401
|
|
|
|
|
|
|
See L<Config::Model::Warper/"Warp follow argument"> for details. |
402
|
|
|
|
|
|
|
|
403
|
|
|
|
|
|
|
=item morph |
404
|
|
|
|
|
|
|
|
405
|
|
|
|
|
|
|
boolean. If 1, C<WarpedNode> tries to recursively copy the value from |
406
|
|
|
|
|
|
|
the old object to the new object using |
407
|
|
|
|
|
|
|
L<copy_from method|Config::Model::Node/"copy_from ( another_node_object )">. |
408
|
|
|
|
|
|
|
When a copy is not possible, undef values |
409
|
|
|
|
|
|
|
are assigned to object elements. |
410
|
|
|
|
|
|
|
|
411
|
|
|
|
|
|
|
=item rules |
412
|
|
|
|
|
|
|
|
413
|
|
|
|
|
|
|
Hash or array ref that specify the property change rules according to the |
414
|
|
|
|
|
|
|
warp master(s) value(s). |
415
|
|
|
|
|
|
|
See L<Config::Model::Warper/"Warp rules argument"> for details |
416
|
|
|
|
|
|
|
on how to specify the warp master values (or combination of values). |
417
|
|
|
|
|
|
|
|
418
|
|
|
|
|
|
|
=back |
419
|
|
|
|
|
|
|
|
420
|
|
|
|
|
|
|
=head2 Effect declaration |
421
|
|
|
|
|
|
|
|
422
|
|
|
|
|
|
|
For a warped node, the effects are declared with these parameters: |
423
|
|
|
|
|
|
|
|
424
|
|
|
|
|
|
|
=over 8 |
425
|
|
|
|
|
|
|
|
426
|
|
|
|
|
|
|
=item B<config_class_name> |
427
|
|
|
|
|
|
|
|
428
|
|
|
|
|
|
|
When requested by the warp master,the C<WarpedNode> creates a new |
429
|
|
|
|
|
|
|
object of the type specified by this parameter: |
430
|
|
|
|
|
|
|
|
431
|
|
|
|
|
|
|
XZ => { config_class_name => 'SlaveZ' } |
432
|
|
|
|
|
|
|
|
433
|
|
|
|
|
|
|
Instead of a string, you can an array ref which contains the class |
434
|
|
|
|
|
|
|
name and constructor arguments : |
435
|
|
|
|
|
|
|
|
436
|
|
|
|
|
|
|
XY => { config_class_name => ['SlaveY', foo => 'bar' ], }, |
437
|
|
|
|
|
|
|
|
438
|
|
|
|
|
|
|
=item B<class> |
439
|
|
|
|
|
|
|
|
440
|
|
|
|
|
|
|
Specify a Perl class to implement the above config class. This Perl Class B<must> inherit |
441
|
|
|
|
|
|
|
L<Config::Model::Node>. |
442
|
|
|
|
|
|
|
|
443
|
|
|
|
|
|
|
=back |
444
|
|
|
|
|
|
|
|
445
|
|
|
|
|
|
|
=head1 Forwarded methods |
446
|
|
|
|
|
|
|
|
447
|
|
|
|
|
|
|
The following methods are forwarded to contained node: |
448
|
|
|
|
|
|
|
|
449
|
|
|
|
|
|
|
fetch_element config_class_name get_element_name has_element |
450
|
|
|
|
|
|
|
is_element_available element_type load fetch_element_value get_type |
451
|
|
|
|
|
|
|
get_cargo_type describe |
452
|
|
|
|
|
|
|
|
453
|
|
|
|
|
|
|
=head1 Methods |
454
|
|
|
|
|
|
|
|
455
|
|
|
|
|
|
|
=head2 name |
456
|
|
|
|
|
|
|
|
457
|
|
|
|
|
|
|
Return the name of the node (even if warped out). |
458
|
|
|
|
|
|
|
|
459
|
|
|
|
|
|
|
=head2 is_accessible |
460
|
|
|
|
|
|
|
|
461
|
|
|
|
|
|
|
Returns true if the node hidden behind this warped node is accessible, |
462
|
|
|
|
|
|
|
i.e. the warp master have values so a node was warped in. |
463
|
|
|
|
|
|
|
|
464
|
|
|
|
|
|
|
=head2 get_actual_node |
465
|
|
|
|
|
|
|
|
466
|
|
|
|
|
|
|
Returns the node object hidden behind the warped node. Croaks if the |
467
|
|
|
|
|
|
|
node is not accessible. |
468
|
|
|
|
|
|
|
|
469
|
|
|
|
|
|
|
=head2 load_data |
470
|
|
|
|
|
|
|
|
471
|
|
|
|
|
|
|
Parameters: C<< ( hash_ref ) >> |
472
|
|
|
|
|
|
|
|
473
|
|
|
|
|
|
|
Load configuration data with a hash ref. The hash ref key must match |
474
|
|
|
|
|
|
|
the available elements of the node carried by the warped node. |
475
|
|
|
|
|
|
|
|
476
|
|
|
|
|
|
|
=head1 EXAMPLE |
477
|
|
|
|
|
|
|
|
478
|
|
|
|
|
|
|
$model ->create_config_class |
479
|
|
|
|
|
|
|
( |
480
|
|
|
|
|
|
|
element => |
481
|
|
|
|
|
|
|
[ |
482
|
|
|
|
|
|
|
tree_macro => { type => 'leaf', |
483
|
|
|
|
|
|
|
value_type => 'enum', |
484
|
|
|
|
|
|
|
choice => [qw/XX XY XZ ZZ/] |
485
|
|
|
|
|
|
|
}, |
486
|
|
|
|
|
|
|
bar => { |
487
|
|
|
|
|
|
|
type => 'warped_node', |
488
|
|
|
|
|
|
|
follow => '! tree_macro', |
489
|
|
|
|
|
|
|
morph => 1, |
490
|
|
|
|
|
|
|
rules => [ |
491
|
|
|
|
|
|
|
XX => { config_class_name |
492
|
|
|
|
|
|
|
=> [ 'ClassX', 'foo' ,'bar' ]} |
493
|
|
|
|
|
|
|
XY => { config_class_name => 'ClassY'}, |
494
|
|
|
|
|
|
|
XZ => { config_class_name => 'ClassZ'} |
495
|
|
|
|
|
|
|
] |
496
|
|
|
|
|
|
|
} |
497
|
|
|
|
|
|
|
] |
498
|
|
|
|
|
|
|
); |
499
|
|
|
|
|
|
|
|
500
|
|
|
|
|
|
|
In the example above we see that: |
501
|
|
|
|
|
|
|
|
502
|
|
|
|
|
|
|
=over |
503
|
|
|
|
|
|
|
|
504
|
|
|
|
|
|
|
=item * |
505
|
|
|
|
|
|
|
|
506
|
|
|
|
|
|
|
The 'bar' slot can refer to a C<ClassX>, C<ClassZ> or C<ClassY> object. |
507
|
|
|
|
|
|
|
|
508
|
|
|
|
|
|
|
=item * |
509
|
|
|
|
|
|
|
|
510
|
|
|
|
|
|
|
The warper object is the C<tree_macro> attribute of the root of the |
511
|
|
|
|
|
|
|
object tree. |
512
|
|
|
|
|
|
|
|
513
|
|
|
|
|
|
|
=item * |
514
|
|
|
|
|
|
|
|
515
|
|
|
|
|
|
|
When C<tree_macro> is set to C<ZZ>, C<bar> is not available. Trying to |
516
|
|
|
|
|
|
|
access C<bar> raises an exception. |
517
|
|
|
|
|
|
|
|
518
|
|
|
|
|
|
|
=item * |
519
|
|
|
|
|
|
|
|
520
|
|
|
|
|
|
|
When C<tree_macro> is changed from C<ZZ> to C<XX>, |
521
|
|
|
|
|
|
|
C<bar> refers to a brand new C<ClassX> |
522
|
|
|
|
|
|
|
object constructed with C<< ClassX->new(foo => 'bar') >> |
523
|
|
|
|
|
|
|
|
524
|
|
|
|
|
|
|
=item * |
525
|
|
|
|
|
|
|
|
526
|
|
|
|
|
|
|
Then, if C<tree_macro> is changed from C<XX> to C<XY>, C<bar> |
527
|
|
|
|
|
|
|
refers to a brand new C<ClassY> object. But in this case, the object is |
528
|
|
|
|
|
|
|
initialized with most if not all the attributes of C<ClassX>. This copy |
529
|
|
|
|
|
|
|
is done whenever C<tree_macro> is changed. |
530
|
|
|
|
|
|
|
|
531
|
|
|
|
|
|
|
=back |
532
|
|
|
|
|
|
|
|
533
|
|
|
|
|
|
|
=head1 AUTHOR |
534
|
|
|
|
|
|
|
|
535
|
|
|
|
|
|
|
Dominique Dumont, (ddumont at cpan dot org) |
536
|
|
|
|
|
|
|
|
537
|
|
|
|
|
|
|
=head1 SEE ALSO |
538
|
|
|
|
|
|
|
|
539
|
|
|
|
|
|
|
L<Config::Model::Instance>, |
540
|
|
|
|
|
|
|
L<Config::Model>, |
541
|
|
|
|
|
|
|
L<Config::Model::HashId>, |
542
|
|
|
|
|
|
|
L<Config::Model::ListId>, |
543
|
|
|
|
|
|
|
L<Config::Model::AnyThing>, |
544
|
|
|
|
|
|
|
L<Config::Model::Warper>, |
545
|
|
|
|
|
|
|
L<Config::Model::WarpedNode>, |
546
|
|
|
|
|
|
|
L<Config::Model::Value> |
547
|
|
|
|
|
|
|
|
548
|
|
|
|
|
|
|
=head1 AUTHOR |
549
|
|
|
|
|
|
|
|
550
|
|
|
|
|
|
|
Dominique Dumont |
551
|
|
|
|
|
|
|
|
552
|
|
|
|
|
|
|
=head1 COPYRIGHT AND LICENSE |
553
|
|
|
|
|
|
|
|
554
|
|
|
|
|
|
|
This software is Copyright (c) 2005-2022 by Dominique Dumont. |
555
|
|
|
|
|
|
|
|
556
|
|
|
|
|
|
|
This is free software, licensed under: |
557
|
|
|
|
|
|
|
|
558
|
|
|
|
|
|
|
The GNU Lesser General Public License, Version 2.1, February 1999 |
559
|
|
|
|
|
|
|
|
560
|
|
|
|
|
|
|
=cut |