File Coverage

blib/lib/Config/Model/WarpedNode.pm
Criterion Covered Total %
statement 112 117 95.7
branch 28 36 77.7
condition 10 19 52.6
subroutine 24 24 100.0
pod 5 13 38.4
total 179 209 85.6


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