File Coverage

blib/lib/Config/Model/Warper.pm
Criterion Covered Total %
statement 200 245 81.6
branch 67 112 59.8
condition 30 35 85.7
subroutine 24 25 96.0
pod 2 13 15.3
total 323 430 75.1


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