File Coverage

blib/lib/Config/Model/Node.pm
Criterion Covered Total %
statement 556 605 91.9
branch 145 208 69.7
condition 83 136 61.0
subroutine 76 81 93.8
pod 39 54 72.2
total 899 1084 82.9


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::Node 2.153; # TRIAL
11              
12 59     59   449 use Mouse;
  59         131  
  59         415  
13             with "Config::Model::Role::NodeLoader";
14              
15 59     59   22136 use Carp;
  59         163  
  59         3341  
16 59     59   1385 use 5.020;
  59         234  
17              
18 59     59   419 use Config::Model::TypeConstraints;
  59         199  
  59         1854  
19 59     59   368 use Config::Model::Instance;
  59         199  
  59         2005  
20 59     59   390 use Config::Model::Exception;
  59         162  
  59         1700  
21 59     59   37140 use Config::Model::Loader;
  59         269  
  59         2269  
22 59     59   31536 use Config::Model::Dumper;
  59         257  
  59         2827  
23 59     59   30016 use Config::Model::DumpAsData;
  59         234  
  59         2329  
24 59     59   26126 use Config::Model::Report;
  59         247  
  59         2139  
25 59     59   27428 use Config::Model::TreeSearcher;
  59         230  
  59         2043  
26 59     59   28993 use Config::Model::Describe;
  59         246  
  59         2321  
27 59     59   30536 use Config::Model::BackendMgr;
  59         253  
  59         2502  
28 59     59   487 use Log::Log4perl qw(get_logger :levels);
  59         193  
  59         349  
29 59     59   7806 use Storable qw/dclone/;
  59         172  
  59         2852  
30 59     59   422 use List::MoreUtils qw(insert_after_string);
  59         170  
  59         438  
31              
32             extends qw/Config::Model::AnyThing/;
33              
34             with "Config::Model::Role::Grab";
35             with "Config::Model::Role::HelpAsText";
36             with "Config::Model::Role::ComputeFunction";
37             with "Config::Model::Role::Constants";
38             with "Config::Model::Role::Utils";
39              
40 59     59   44098 use feature qw/signatures postderef/;
  59         191  
  59         6340  
41 59     59   472 no warnings qw/experimental::signatures experimental::postderef/;
  59         184  
  59         553521  
42              
43             my %legal_properties = (
44             status => {qw/obsolete 1 deprecated 1 standard 1/},
45             level => {qw/important 1 normal 1 hidden 1/},
46             );
47              
48             my $logger = get_logger("Tree::Node");
49             my $fix_logger = get_logger("Anything::Fix");
50             my $change_logger = get_logger("ChangeTracker");
51             my $deep_check_logger = get_logger('DeepCheck');
52             my $user_logger = get_logger('User');
53              
54             # Here are the legal element types
55             my %create_sub_for = (
56             node => \&create_node,
57             leaf => \&create_leaf,
58             hash => \&create_id,
59             list => \&create_id,
60             check_list => \&create_id,
61             warped_node => \&create_warped_node,
62             );
63              
64             # Node internal documentation
65             #
66             # Since the class holds a significant number of element, here's its
67             # main structure.
68             #
69             # $self
70             # = (
71             # config_model : Weak reference to Config::Model object
72             # config_class_name
73             # model : model of the config class
74             # instance : Weak reference to Config::Model::Instance object
75             # element_name : Name of the element containing this node
76             # (undef for root node).
77             # parent : weak reference of parent node (undef for root node)
78             # element : actual storage of configuration elements
79              
80             # ) ;
81              
82             has initialized => ( is => 'rw', isa => 'Bool', default => 0 );
83              
84             has config_class_name => ( is => 'ro', isa => 'Str', required => 1 );
85              
86             has gist => (
87             is => 'rw',
88             isa => 'Str',
89             default => '',
90             );
91              
92             sub fetch_gist {
93 4     4 1 12 my $self = shift;
94 4   50     21 my $gist = $self->gist // '';
95 4   50     38 $gist =~ s!{([\w -]+)}!$self->grab($1)->fetch // ''!ge;
  8         39  
96 4         47 return $gist;
97             }
98              
99             has config_file => ( is => 'ro', isa => 'Config::Model::TypeContraints::Path', required => 0 );
100             has element_name => ( is => 'ro', isa => 'Maybe[Str]', required => 0 );
101              
102             has instance => (
103             is => 'ro',
104             isa => 'Config::Model::Instance',
105             weak_ref => 1,
106             required => 1,
107             handles => [qw/read_check/],
108             );
109              
110             has config_model => (
111             is => 'ro',
112             isa => 'Config::Model',
113             weak_ref => 1,
114             lazy => 1,
115             builder => '_config_model'
116             );
117              
118             sub _config_model {
119 785     785   1567 my $self = shift;
120 785         5618 return $self->instance->config_model;
121             }
122              
123             has model => ( is => 'rw', isa => 'HashRef' );
124             has needs_save => ( is => 'rw', isa => 'Bool', default => 0 );
125              
126             has backend_mgr => ( is => 'ro', isa => 'Maybe[Config::Model::BackendMgr]' );
127              
128             # used to avoid warning twice about a deprecated element. Internal methods
129             has warned_deprecated_element => (
130             is => 'ro',
131             isa => 'HashRef[Str]',
132             traits => ['Hash'],
133             default => sub { {}; },
134             handles => {
135             warn_element_done => 'set',
136             was_element_warned => 'defined',
137             }
138             ) ;
139              
140             # attribute is defined in Config::Model::Anything
141             sub _backend_support_annotation {
142 11     11   35 my $self = shift;
143 11 50       126 return $self->backend_mgr ? $self->backend_mgr->support_annotation
    100          
144             : $self->parent ? $self->parent->backend_support_annotation
145             : undef ; # no backend at all. test only
146             }
147              
148             sub BUILD {
149 785     785 1 1677 my $self = shift;
150              
151 785 100       3995 my $caller_class = defined $self->parent ? $self->parent->name : 'user';
152              
153 785         2088 my $class_name = $self->config_class_name;
154 785         3379 $logger->debug("New $class_name requested by $caller_class");
155              
156 785         9617 $self->{original_model} = $self->config_model->model($class_name);
157 785         55325 $self->model( dclone($self->{original_model}) ) ;
158              
159 785         3172 $self->check_properties;
160              
161 785         10928 return $self;
162             }
163              
164             ## Create_* methods are all internal and should not be used directly
165              
166 3712     3712 0 5323 sub create_element ($self, @args) {
  3712         5251  
  3712         7601  
  3712         5343  
167 3712         9927 my %args = _resolve_arg_shortcut(\@args, 'name');
168 3712         7861 my $element_name = $args{name};
169 3712   50     8747 my $check = $args{check} || 'yes';
170              
171 3712         8880 my $element_info = $self->{model}{element}{$element_name};
172              
173 3712 100       7364 if ( not defined $element_info ) {
174 2 100       11 if ( $check eq 'yes' ) {
175 1   50     26 Config::Model::Exception::UnknownElement->throw(
176             object => $self,
177             where => $self->location || 'configuration root',
178             element => $element_name,
179             );
180             }
181             else {
182 1         5 return; # just skip when check is no or skip
183             }
184             }
185              
186             Config::Model::Exception::Model->throw(
187 3710 50       8811 error => "element '$element_name' error: " . "passed information is not a hash ref",
188             object => $self
189             ) unless ref($element_info) eq 'HASH';
190              
191             Config::Model::Exception::Model->throw(
192             error => "create element '$element_name' error: " . "missing 'type' parameter",
193             object => $self
194 3710 50       8513 ) unless defined $element_info->{type};
195              
196 3710         8607 my $method = $create_sub_for{ $element_info->{type} };
197              
198             croak $self->{config_class_name},
199 3710 50       6893 " error: unknown element type $element_info->{type}, expected ",
200             join(' ', sort keys %create_sub_for)
201             unless defined $method;
202              
203 3710         8880 return $self->$method( $element_name, $check );
204             }
205              
206             sub create_node {
207 183     183 0 538 my ( $self, $element_name, $check ) = @_;
208              
209 183         4933 my $element_info = dclone( $self->{model}{element}{$element_name} );
210 183         644 my $config_class_name = $element_info->{config_class_name};
211              
212             Config::Model::Exception::Model->throw(
213             error => "create node '$element_name' error: " . "missing config class name parameter",
214             object => $self
215 183 50       667 ) unless defined $element_info->{config_class_name};
216              
217             my @args = (
218             config_class_name => $config_class_name,
219             instance => $self->{instance},
220 183         815 element_name => $element_name,
221             parent => $self,
222             container => $self,
223             );
224              
225 183         742 return $self->{element}{$element_name} = $self->load_node(@args);
226             }
227              
228             sub create_warped_node {
229 126     126 0 547 my ( $self, $element_name, $check ) = @_;
230              
231 126         5864 my $element_info = dclone( $self->{model}{element}{$element_name} );
232              
233             my @args = (
234             instance => $self->{instance},
235 126         979 element_name => $element_name,
236             parent => $self,
237             check => $check,
238             container => $self,
239             );
240              
241 126         14657 require Config::Model::WarpedNode;
242              
243 126         1429 return $self->{element}{$element_name} =
244             Config::Model::WarpedNode->new( %$element_info, @args );
245             }
246              
247             sub create_leaf {
248 2812     2812 0 6373 my ( $self, $element_name, $check ) = @_;
249              
250 2812         77429 my $element_info = dclone( $self->{model}{element}{$element_name} );
251              
252 2812         8876 delete $element_info->{type};
253 2812   100     10581 my $leaf_class = delete $element_info->{class} || 'Config::Model::Value';
254              
255 2812 100       4354 if ( not defined *{ $leaf_class . '::' } ) {
  2812         14478  
256 1         4 my $file = $leaf_class . '.pm';
257 1         7 $file =~ s!::!/!g;
258 1         490 require $file;
259             }
260              
261 2812         6463 $element_info->{container} = $element_info->{parent} = $self;
262 2812         5259 $element_info->{element_name} = $element_name;
263 2812         6073 $element_info->{instance} = $self->{instance};
264              
265 2812         24726 return $self->{element}{$element_name} = $leaf_class->new(%$element_info);
266             }
267              
268             my %id_class_hash = (
269             hash => 'HashId',
270             list => 'ListId',
271             check_list => 'CheckList',
272             );
273              
274             sub create_id {
275 589     589 0 1650 my ( $self, $element_name, $check ) = @_;
276              
277 589         20848 my $element_info = dclone( $self->{model}{element}{$element_name} );
278 589         2359 my $type = delete $element_info->{type};
279              
280 589 50       1666 Config::Model::Exception::Model->throw(
281             error => "create $type element '$element_name' error" . ": missing 'type' parameter",
282             object => $self
283             ) unless defined $type;
284              
285             croak "Undefined id_class for type '$type'"
286 589 50       1857 unless defined $id_class_hash{$type};
287              
288             my $id_class = delete $element_info->{class}
289 589   66     3343 || 'Config::Model::' . $id_class_hash{$type};
290              
291 589 100       1069 if ( not defined *{ $id_class . '::' } ) {
  589         3344  
292 81         273 my $file = $id_class . '.pm';
293 81         578 $file =~ s!::!/!g;
294 81         55033 require $file;
295             }
296              
297 589         1883 $element_info->{container} = $element_info->{parent} = $self;
298 589         1325 $element_info->{element_name} = $element_name;
299 589         1374 $element_info->{instance} = $self->{instance};
300              
301 589         6238 return $self->{element}{$element_name} = $id_class->new(%$element_info);
302             }
303              
304             # check validity of level and status declaration.
305             sub check_properties {
306 785     785 0 1492 my $self = shift;
307              
308             # a model should no longer contain attributes attached to
309             # an element (like description, level ...). There are copied here
310             # because Node needs them as hash or lists
311 785         2084 foreach my $bad (qw/description summary level status/) {
312             die $self->config_class_name, ": illegal '$bad' parameter in model ",
313             "(Should be handled by Config::Model directly)\n"
314 3140 50       7261 if defined $self->{model}{$bad};
315             }
316              
317 785         1352 foreach my $elt_name ( @{ $self->{model}{element_list} } ) {
  785         2397  
318              
319 4278         6516 foreach my $prop (qw/summary description/) {
320 8556         14429 my $info_to_move = delete $self->{model}{element}{$elt_name}{$prop};
321 8556 100       17085 $self->{$prop}{$elt_name} = $info_to_move
322             if defined $info_to_move;
323             }
324              
325 4278         8789 foreach my $prop ( keys %legal_properties ) {
326             my $prop_v
327 8556   66     23911 = delete $self->{model}{element}{$elt_name}{$prop}
328             // get_default_property($prop) ;
329 8556         16523 $self->{$prop}{$elt_name} = $prop_v;
330              
331             croak "Config class $self->{config_class_name} error: ",
332 0         0 "Unknown $prop: '$prop_v'. Expected ", join( " or ", keys %{ $self->{$prop} } )
333 8556 50       20267 unless defined $legal_properties{$prop}{$prop_v};
334             }
335             }
336 785         1550 return;
337             }
338              
339 22781     22781 0 37434 sub init ($self, @args) {
  22781         32061  
  22781         30847  
  22781         30531  
340 22781 100       53522 return if $self->{initialized};
341 743         1566 $self->{initialized} = 1; # avoid recursions
342              
343 743         1442 my $model = $self->{model};
344              
345 743 100       2184 return unless defined $model->{rw_config};
346              
347 93         508 my $initial_load_backup = $self->instance->initial_load;
348 93         563 $self->instance->initial_load_start;
349              
350             $self->{backend_mgr} ||= Config::Model::BackendMgr->new(
351             # config_dir spec given by application info
352             config_dir => $self->instance->config_dir,
353             node => $self,
354             rw_config => $model->{rw_config}
355 93   33     2987 );
356              
357 93         574 $self->read_config_data( check => $self->read_check );
358             # setup auto_write
359 93         598 $self->backend_mgr->auto_write_init();
360              
361 93         1013 $self->instance->initial_load($initial_load_backup);
362 93         1059 return;
363             }
364              
365             sub read_config_data {
366 99     99 0 2067 my ( $self, %args ) = @_;
367              
368 99         226 my $model = $self->{model};
369              
370 99 50 66     691 if ( $self->location and $args{config_file} ) {
371 0         0 die "read_config_data: cannot override config_file in non root node (",
372             $self->location, ")\n";
373             }
374              
375             # setup auto_read
376             # may use an overridden config file
377             return $self->backend_mgr->read_config_data(
378             check => $args{check},
379             config_file => $args{config_file} || $self->{config_file},
380 99   100     1430 auto_create => $args{auto_create} || $self->instance->auto_create,
      33        
381             );
382             }
383              
384             around notify_change => sub ($orig, $self, %args) {
385             if ($change_logger->is_trace) {
386             my @with = map { "'$_' -> '". ($args{$_} // '<undef>') ."'" } sort keys %args;
387             $change_logger->trace("called for ", $self->name, " from ", join( ' ', caller ), " with ", join( ' ', @with ));
388             }
389             return if $self->instance->initial_load and not $args{really};
390              
391             $logger->trace( "called while needs_write is ", $self->needs_save, " for ", $self->name )
392             if $logger->is_trace;
393              
394             if ( defined $self->backend_mgr ) {
395             $self->needs_save(1); # will trigger a save in config_file
396             $self->$orig( %args, needs_save => 0 );
397             }
398             else {
399             # save config_file will be done by a node above
400             $self->$orig( %args, needs_save => 1 );
401             }
402             return;
403             };
404              
405 18     18 0 37 sub is_auto_write_for_type ($self, @args) {
  18         30  
  18         33  
  18         36  
406 18 100       113 return 0 unless defined $self->backend_mgr;
407 1         7 return $self->backend_mgr->is_auto_write_for_type(@args);
408             }
409              
410             sub name {
411 20896     20896 1 34685 my $self = shift;
412 20896   66     116813 return $self->location() || $self->config_class_name;
413             }
414              
415             sub get_type {
416 828     828 1 1970 return 'node';
417             }
418              
419             sub get_cargo_type {
420 705     705 0 1396 return 'node';
421             }
422              
423             # always true. this method is required so that WarpedNode and Node
424             # have a similar API.
425             sub is_accessible {
426 0     0 0 0 return 1;
427             }
428              
429             # should I autovivify this element: NO
430 4140     4140 1 6399 sub has_element ($self, @args) {
  4140         6698  
  4140         8433  
  4140         5591  
431 4140         10776 my %args = _resolve_arg_shortcut(\@args, 'name');
432 4140         8925 my $name = $args{name};
433 4140         6649 my $type = $args{type};
434 4140   100     10602 my $autoadd = $args{autoadd} // 1;
435              
436 4140 50       8697 if ( not defined $name ) {
437 0         0 Config::Model::Exception::Internal->throw(
438             object => $self,
439             info => "has_element: missing element name",
440             );
441             }
442              
443 4140 100       14046 $self->accept_element($name) if $autoadd;
444 4140 100       10267 return 0 unless defined $self->{model}{element}{$name};
445 3916 100       16660 return 1 unless defined $type;
446 2 100       16 return $self->{model}{element}{$name}{type} eq $type ? 1 : 0;
447             }
448              
449             # should I autovivify this element: NO
450             sub find_element {
451 0     0 1 0 my ( $self, $name, %args ) = @_;
452 0 0       0 croak "find_element: missing element name" unless defined $name;
453              
454             # should be the case if people are using cme edit
455 0 0       0 return $name if defined $self->{model}{element}{$name};
456              
457             # look for a close element playing with cases;
458 0 0 0     0 if ( defined $args{case} and $args{case} eq 'any' ) {
459 0         0 foreach my $elt ( keys %{ $self->{model}{element} } ) {
  0         0  
460 0 0       0 return $elt if lc($elt) eq lc($name);
461             }
462             }
463              
464             # now look if the element can be accepted
465 0         0 $self->accept_element($name);
466 0 0       0 return $name if defined $self->{model}{element}{$name};
467              
468 0         0 return;
469             }
470              
471 0     0 1 0 sub element_model ($self, $elt_name) {
  0         0  
  0         0  
  0         0  
472 0         0 return $self->{model}{element}{ $elt_name };
473             }
474              
475             sub element_type {
476 12570     12570 1 22866 my ($self, $name) = @_;
477 12570 50       26309 croak "element_type: missing element name" unless $name;
478              
479 12570   66     35424 my $element_info = $self->{model}{element}{$name} // $self-> _get_accepted_data($name);
480              
481 12570 50 0     23599 Config::Model::Exception::UnknownElement->throw(
482             object => $self,
483             function => 'element_type',
484             where => $self->location || 'configuration root',
485             element => $name,
486             ) unless defined $element_info;
487              
488 12570         39398 return $element_info->{type};
489             }
490              
491             sub get_element_name {
492 1463     1463 0 6845 goto &get_element_names;
493             }
494              
495 1495     1495 1 2596 sub get_element_names ($self, %args) {
  1495         2233  
  1495         2716  
  1495         1966  
496 1495 50       3544 if (delete $args{for}) {
497 0         0 carp "get_element_names arg 'for' is deprecated";
498             }
499              
500 1495         2432 my $type = $args{type}; # optional
501 1495         2335 my $cargo_type = $args{cargo_type}; # optional
502              
503 1495         3975 $self->init();
504              
505 1495         2219 my @result;
506              
507 1495         3147 my $info = $self->{model};
508 1495         2237 my @element_list = @{ $self->{model}{element_list} };
  1495         6737  
509              
510 1495 100       3695 if ($args{all}) {
511 21         76 my @res = grep { $self->{level}{$_} ne 'hidden' } @element_list;
  42         183  
512 21 50       140 return wantarray ? @res : "@res";
513             }
514              
515             # this is a bit convoluted, but the order of the returned element
516             # must respect the order of the elements declared in the model by
517             # the user
518 1474         3058 foreach my $elt (@element_list) {
519              
520             # create element if they don't exist, this enables warp stuff
521             # to kick in
522             $self->create_element( name => $elt, check => $args{check} || 'yes' )
523 8610 100 100     25816 unless defined $self->{element}{$elt};
524              
525 8610 100       24232 next if $self->{level}{$elt} eq 'hidden';
526              
527 8517   33     19144 my $status = $self->{status}{$elt} || get_default_property('status');
528 8517 100 100     24613 next if ( $status eq 'deprecated' or $status eq 'obsolete' );
529              
530 8461         23590 my $elt_type = $self->{element}{$elt}->get_type;
531 8461         19872 my $elt_cargo = $self->{element}{$elt}->get_cargo_type;
532 8461 100 33     29196 if ( ( not defined $type or $type eq $elt_type )
      100        
      66        
533             and ( not defined $cargo_type or $cargo_type eq $elt_cargo ) ) {
534 8335         18097 push @result, $elt;
535             }
536             }
537              
538 1474         8213 $logger->trace("got @result");
539              
540 1474 50       19283 return wantarray ? @result : join( ' ', @result );
541             }
542              
543             sub children {
544 2     2 1 5 my $self = shift;
545 2         5 return $self->get_element_names;
546             }
547              
548 239     239 1 1667 sub next_element ($self, %args) {
  239         305  
  239         559  
  239         294  
549 239         371 my $element = $args{name};
550              
551 239         334 my @elements = @{ $self->{model}{element_list} };
  239         710  
552 239 100       519 @elements = reverse @elements if $args{reverse};
553              
554             # if element is empty, start from first element
555 239 100 100     802 my $found_elt = ( defined $element and $element ) ? 0 : 1;
556              
557 239         555 while ( my $name = shift @elements ) {
558 1046 100       1699 if ($found_elt) {
559             return $name
560             if $self->is_element_available(
561             name => $name,
562 206 100       528 status => $args{status} );
563             }
564 843 100 66     2753 $found_elt = 1 if defined $element and $element eq $name;
565             }
566              
567 36 50       89 croak "next_element: element $element is unknown. Expected @elements"
568             unless $found_elt;
569 36         88 return;
570             }
571              
572 3     3 1 7 sub previous_element ($self, @args) {
  3         5  
  3         7  
  3         5  
573 3         10 return $self->next_element( @args, reverse => 1 );
574             }
575              
576 31395     31395 1 42560 sub get_element_property ($self, %args) {
  31395         41002  
  31395         64124  
  31395         39166  
577 31395         72344 my ( $prop, $elt ) = $self->check_property_args( 'get_element_property', %args );
578              
579 31395   33     97910 return $self->{$prop}{$elt} || get_default_property($prop);
580             }
581              
582 242     242 1 478 sub set_element_property ($self, %args) {
  242         430  
  242         693  
  242         372  
583 242         840 my ( $prop, $elt ) = $self->check_property_args( 'set_element_property', %args );
584              
585             my $new_value = $args{value}
586 242   33     831 || croak "set_element_property:: missing 'value' parameter";
587              
588 242         735 $logger->debug( "Node ", $self->name, ": set $elt property $prop to $new_value" );
589              
590 242         2511 return $self->{$prop}{$elt} = $new_value;
591             }
592              
593 718     718 1 1138 sub reset_element_property ($self, %args) {
  718         1105  
  718         1763  
  718         997  
594 718         2212 my ( $prop, $elt ) = $self->check_property_args( 'reset_element_property', %args );
595              
596             my $original_value = $self->{config_model}->get_element_property(
597             class => $self->{config_class_name},
598 718         3804 %args
599             );
600              
601 718         2957 $logger->debug( "Node ", $self->name, ": reset $elt property $prop to $original_value" );
602              
603 718         8337 return $self->{$prop}{$elt} = $original_value;
604             }
605              
606             # internal: called by the property methods to check their arguments
607 32355     32355 0 42288 sub check_property_args ($self, $method_name, %args){
  32355         41592  
  32355         42009  
  32355         53881  
  32355         40248  
608             my $elt = $args{element}
609 32355   33     64337 || croak "$method_name: missing 'element' parameter";
610             my $prop = $args{property}
611 32355   33     56790 || croak "$method_name: missing 'property' parameter";
612              
613 32355         49308 my $prop_values = $legal_properties{$prop};
614 32355 50       56633 confess "Unknown property in $method_name: $prop, expected status or ", "level"
615             unless defined $prop_values;
616              
617 32355         86139 return ( $prop, $elt );
618             }
619              
620 21028     21028 1 437683 sub fetch_element ($self, @args) {
  21028         30158  
  21028         41622  
  21028         26411  
621 21028         52870 my %args = _resolve_arg_shortcut(\@args, 'name');
622 21028         41004 my $element_name = $args{name};
623              
624 21028 50       41088 Config::Model::Exception::Internal->throw( error => "fetch_element: missing name" )
625             unless defined $element_name;
626              
627 21028         60187 my $check = $self->_check_check( $args{check} );
628 21028   100     61110 my $accept_hidden = $args{accept_hidden} || 0;
629 21028   100     53926 my $autoadd = $args{autoadd} // 1;
630              
631 21028         51725 $self->init();
632              
633 21028         32390 my $model = $self->{model};
634              
635             # retrieve element (and auto-vivify if needed)
636 21028 100       47861 if ( not defined $self->{element}{$element_name} ) {
637              
638             # We also need to check if element name is matched by any of 'accept' parameters
639 1472 100       4924 $self->accept_element($element_name) if $autoadd;
640 1472 100       3925 $self->create_element( name => $element_name, check => $check ) or return;
641             }
642              
643             # check level
644 21018         45135 my $element_level = $self->get_element_property(
645             property => 'level',
646             element => $element_name
647             );
648              
649 21018 100 100     51344 if ( $element_level eq 'hidden' and not $accept_hidden ) {
650 4 50 33     30 return 0 if ( $check eq 'no' or $check eq 'skip' );
651 4         93 Config::Model::Exception::UnavailableElement->throw(
652             object => $self,
653             element => $element_name,
654             info => 'hidden element',
655             );
656             }
657              
658             # check status
659 21014 100       46780 if ( $self->{status}{$element_name} eq 'obsolete' ) {
660              
661             # obsolete is a status not very different from a missing
662             # item. The only difference is that user will get more
663             # information
664 1 50 33     8 return 0 if ( $check eq 'no' or $check eq 'skip' );
665 1         23 Config::Model::Exception::ObsoleteElement->throw(
666             object => $self,
667             element => $element_name,
668             );
669             }
670              
671             # do not warn when when is skip or "no"
672 21013 100 100     46766 if ($self->{status}{$element_name} eq 'deprecated' and $check eq 'yes' ) {
673             # FIXME elaborate more ? or include parameter description ??
674 19         109 my $msg = "Element '$element_name' of node '". $self->name. "' is deprecated";
675 19 100       154 if (not $self->was_element_warned($element_name)) {
676 11         286 $user_logger->warn($msg);
677 11         692 $self->warn_element_done($element_name,1);
678             }
679             # this will also force a rewrite of the file even if no other
680             # semantic change was done
681             $self->notify_change(
682 19         688 note => 'dropping deprecated parameter',
683             path => $self->location . ' ' . $element_name,
684             really => 1,
685             );
686             }
687              
688 21013         39400 return $self->fetch_element_no_check($element_name);
689             }
690              
691             sub fetch_element_no_check {
692 21013     21013 0 35650 my ( $self, $element_name ) = @_;
693 21013         70626 return $self->{element}{$element_name};
694             }
695              
696 471     471 1 1246 sub fetch_element_value ($self, @args) {
  471         736  
  471         839  
  471         653  
697 471 50       1508 my %args = @args > 1 ? @args : ( name => $args[0] );
698 471         842 my $element_name = $args{name};
699 471         1813 my $check = $self->_check_check( $args{check} );
700              
701 471 50       1451 if ( $self->element_type($element_name) ne 'leaf' ) {
702 0         0 Config::Model::Exception::WrongType->throw(
703             object => $self->fetch_element($element_name),
704             function => 'fetch_element_value',
705             got_type => $self->element_type($element_name),
706             expected_type => 'leaf',
707             );
708             }
709              
710 471         1627 return $self->fetch_element(%args)->fetch( check => $check );
711             }
712              
713 2     2 1 5 sub store_element_value ($self, @args) {
  2         4  
  2         4  
  2         4  
714 2         9 my %args = _resolve_arg_shortcut(\@args, 'name', 'value');
715              
716 2         17 return $self->fetch_element(%args)->store(%args);
717             }
718              
719 5082     5082 1 7369 sub is_element_available ($self, @args) {
  5082         7037  
  5082         9206  
  5082         6567  
720 5082         10019 my ( $elt_name, $status ) = ( undef, 'deprecated' );
721 5082 100       10634 if ( @args == 1 ) {
722 6         12 $elt_name = $args[0];
723             }
724             else {
725 5076         11400 my %args = @args;
726 5076         8547 $elt_name = $args{name};
727 5076 100       13364 $status = $args{status} if defined $args{status};
728             }
729              
730 5082 50       10756 croak "is_element_available: missing name parameter"
731             unless defined $elt_name;
732              
733             # force the warp to be done (if possible) so the catalog name
734             # is updated
735             # retrieve element (and auto-vivify if needed)
736 5082         12063 my $element = $self->fetch_element(
737             name => $elt_name,
738             # check => 'no' causes problem because elements below (when
739             # loaded by another backend also below) are initialised with
740             # check 'no'. Deprecated elements are loaded but changes are
741             # not notified because of check/no.
742             check => 'skip',
743             accept_hidden => 1
744             );
745              
746 5082         10537 my $element_level = $self->get_element_property(
747             property => 'level',
748             element => $elt_name
749             );
750              
751 5082 100       10904 if ( $element_level eq 'hidden' ) {
752 16         121 $logger->trace("element $elt_name is level hidden -> return 0");
753 16         224 return 0;
754             }
755              
756 5066         9748 my $element_status = $self->get_element_property(
757             property => 'status',
758             element => $elt_name
759             );
760              
761 5066 50 66     14429 if ( $element_status ne 'standard' and $element_status ne $status ) {
762 0         0 $logger->trace("element $elt_name is status $element_status -> return 0");
763 0         0 return 0;
764             }
765              
766 5066         19717 return 1;
767             }
768              
769             sub accept_element {
770 5531     5531 1 10903 my ( $self, $name ) = @_;
771              
772 5531         10122 my $model_data = $self->{model}{element};
773              
774 5531 100       16259 return $model_data->{$name} if defined $model_data->{$name};
775              
776 220         707 my $acc = $self-> _get_accepted_data($name);
777              
778 220 100       575 return $self->reset_accepted_element_model( $name, $acc ) if $acc;
779              
780 195         380 return;
781             }
782              
783             # return accepted model data or undef
784             sub _get_accepted_data {
785 221     221   505 my ( $self, $name ) = @_;
786              
787 221 50       566 return unless defined $self->{model}{accept};
788              
789 221         410 eval {require Text::Levenshtein::Damerau} ;
  221         9048  
790 221         33341 my $has_tld = ! $@ ;
791              
792 221         348 foreach my $accept_regexp ( @{ $self->{model}{accept_list} } ) {
  221         702  
793 64 100       947 next unless $name =~ /^$accept_regexp$/;
794 26         98 my $element_list = $self->{original_model}{element_list} ;
795              
796 26 100 33     191 if ($has_tld and $element_list and @$element_list) {
      66        
797 14         72 my $tld = Text::Levenshtein::Damerau->new($name);
798 14         209 my $tld_arg = {list => $element_list };
799 14         47 my $dist = $tld->dld_best_distance($tld_arg);
800 14 100       16580 if ($dist < 3) {
801 4         13 my $best = $tld->dld_best_match($tld_arg);
802 4         3790 $user_logger->warn(
803             "Warning: ".$self->location
804             ." '$name' is confusingly close to '$best' (edit distance is $dist)."
805             ." Is there a typo ?"
806             );
807             }
808              
809             }
810              
811 26         474 return $self->{model}{accept}{$accept_regexp};
812             }
813              
814 195         415 return ;
815             }
816              
817             sub accept_regexp {
818 5     5 1 21 my ($self) = @_;
819              
820 5 50       9 return @{ $self->{model}{accept_list} || [] };
  5         42  
821             }
822              
823             sub reset_accepted_element_model {
824 25     25 0 70 my ( $self, $element_name, $accept_model ) = @_;
825              
826 25         924 my $model = dclone $accept_model ;
827 25         79 delete $model->{name_match};
828 25         56 my $accept_after = delete $model->{accept_after};
829              
830 25         66 foreach my $info_to_move (qw/description summary/) {
831 50         86 my $moved_data = delete $model->{$info_to_move};
832 50 50       124 next unless defined $moved_data;
833 0         0 $self->{$info_to_move}{$element_name} = $moved_data;
834             }
835              
836 25         64 foreach my $info_to_move (qw/level status/) {
837 50         160 $self->reset_element_property(
838             element => $element_name,
839             property => $info_to_move
840             );
841             }
842              
843 25         70 $self->{model}{element}{$element_name} = $model;
844              
845             #add to element list...
846 25 100       65 if ($accept_after) {
847 3         7 insert_after_string( $accept_after, $element_name, @{ $self->{model}{element_list} } );
  3         25  
848             }
849             else {
850 22         35 push @{ $self->{model}{element_list} }, $element_name;
  22         79  
851             }
852              
853 25         68 return ($model);
854             }
855              
856             sub element_exists {
857 0     0 1 0 my $self = shift;
858 0         0 my $element_name = shift;
859              
860 0 0       0 return defined $self->{model}{element}{$element_name} ? 1 : 0;
861             }
862              
863 393     393 1 635 sub is_element_defined ($self, $elt_name) {
  393         624  
  393         579  
  393         569  
864 393         2158 return defined $self->{element}{ $elt_name };
865             }
866              
867 7     7 1 2510 sub get ($self, @args) {
  7         11  
  7         21  
  7         8  
868 7         23 my %args = _resolve_arg_shortcut(\@args, 'path');
869 7         19 my $path = delete $args{path};
870 7   100     24 my $get_obj = delete $args{get_obj} || 0;
871 7         26 $path =~ s!^/!!;
872 7 50       18 return $self unless length($path);
873 7         21 my ( $item, $new_path ) = split m!/!, $path, 2;
874 7         35 $logger->trace("get: path $path, item $item");
875 7         67 my $elt = $self->fetch_element( name => $item, %args );
876              
877 7 100       25 return unless defined $elt;
878 6 100 100     20 return $elt if ( ( $elt->get_type ne 'leaf' or $get_obj ) and not defined $new_path );
      100        
879 5         23 return $elt->get( path => $new_path, get_obj => $get_obj, %args );
880             }
881              
882 2     2 1 4 sub set ($self, $path, @args) {
  2         4  
  2         4  
  2         4  
  2         3  
883 2         10 $path =~ s!^/!!;
884 2         8 my ( $item, $new_path ) = split m!/!, $path, 2;
885 2 50       7 if ( $item =~ /([\w\-]+)\[(\d+)\]/ ) {
886 0         0 return $self->fetch_element($1)->fetch_with_id($2)->set( $new_path, @args );
887             }
888             else {
889 2         6 return $self->fetch_element($item)->set( $new_path, @args );
890             }
891             }
892              
893 410     410 1 221922 sub load ($self, @args) {
  410         725  
  410         953  
  410         637  
894 410         4502 my $loader = Config::Model::Loader->new( start_node => $self );
895              
896 410         4870 my %args = _resolve_arg_shortcut(\@args, 'steps');
897 410 50 66     2215 if ( defined $args{step} || defined $args{steps}) {
898 410         2017 return $loader->load( %args );
899             }
900             Config::Model::Exception::Load->throw(
901 0         0 object => $self,
902             message => "load called with no 'steps' parameter",
903             );
904 0         0 return;
905             }
906              
907 131     131 1 5843 sub load_data ($self, @args) {
  131         228  
  131         350  
  131         198  
908 131         481 my %args = _resolve_arg_shortcut(\@args, 'data');
909              
910 131         391 my $raw_perl_data = delete $args{data};
911 131         578 my $check = $self->_check_check( $args{check} );
912              
913 131 50 33     698 if (
914             not defined $raw_perl_data
915             or (
916             ref($raw_perl_data) ne 'HASH'
917              
918             #and not $raw_perl_data->isa( 'HASH' )
919             )
920             ) {
921 0 0       0 Config::Model::Exception::LoadData->throw(
922             object => $self,
923             message => "load_data called with non hash ref arg",
924             wrong_data => $raw_perl_data,
925             ) if $check eq 'yes';
926 0         0 return;
927             }
928              
929 131         3979 my $perl_data = dclone $raw_perl_data ;
930              
931 131         1572 $logger->info(
932             "Node load_data (",
933             $self->location,
934             ") will load elt ",
935             join( ' ', sort keys %$perl_data ) );
936              
937 131         1357 my $has_stored = 0;
938             # data must be loaded according to the element order defined by
939             # the model. This will not load not yet accepted parameters
940 131         291 foreach my $elt ( @{ $self->{model}{element_list} } ) {
  131         429  
941 670         2359 $logger->trace("check element $elt");
942 670 100       5809 next unless defined $perl_data->{$elt};
943              
944 331 50 33     975 if ( $self->is_element_available( name => $elt )
    0          
945             or $check eq 'no' ) {
946 331 100       1059 if ( $logger->is_trace ) {
947 27 50       143 my $v = defined $perl_data->{$elt} ? $perl_data->{$elt} : '<undef>';
948 27         112 $logger->trace("Node load_data for element $elt -> $v");
949             }
950 331         2544 my $obj = $self->fetch_element(
951             name => $elt,
952             check => $check
953             );
954              
955 331 50       818 if ($obj) {
    0          
956 331         1798 $has_stored += $obj->load_data( %args, data => delete $perl_data->{$elt} );
957             }
958             elsif ( defined $obj ) {
959              
960             # skip hidden elements and trash corresponding data
961 0         0 $logger->trace("Node load_data drop element $elt");
962 0         0 delete $perl_data->{$elt};
963             }
964              
965             }
966             elsif ( $check eq 'skip' ) {
967 0         0 $logger->trace("Node load_data skips element $elt");
968             }
969             else {
970             Config::Model::Exception::LoadData->throw(
971             message => "load_data: tried to load hidden " . "element '$elt' with",
972 0         0 wrong_data => $perl_data->{$elt},
973             object => $self,
974             );
975             }
976             }
977              
978             # Load elements matched by accept parameter
979 131 50       495 if ( defined $self->{model}{accept} ) {
980              
981             # Now, $perl_data contains all elements not yet parsed
982             # sort is required to have a predictable order of accepted elements
983 131         414 foreach my $elt ( sort keys %$perl_data ) {
984              
985             #load value
986             #TODO: annotations
987 12         40 my $obj = $self->fetch_element( name => $elt, check => $check );
988 12 50       35 next unless $obj; # in cas of known but unavailable elements
989 12         68 $logger->info("Node load_data: accepting element $elt");
990 12 50       159 $has_stored += $obj->load_data( %args, data => delete $perl_data->{$elt} ) if defined $obj;
991             }
992             }
993              
994 131 50 33     403 if ( %$perl_data and $check eq 'yes' ) {
995             Config::Model::Exception::LoadData->throw(
996             message => "load_data: unknown elements (expected "
997 0         0 . join( ' ', @{ $self->{model}{element_list} } ) . ") ",
  0         0  
998             wrong_data => $perl_data,
999             object => $self,
1000             );
1001             }
1002 131         841 return !! $has_stored;
1003             }
1004              
1005 154     154 1 49596 sub dump_tree ($self, %args) {
  154         329  
  154         348  
  154         246  
1006 154         488 $self->init();
1007 154   50     876 my $full = delete $args{full_dump} || 0;
1008 154 50       421 if ($full) {
1009 0         0 carp "dump_tree: full_dump parameter is deprecated. Please use 'mode => user' instead";
1010 0   0     0 $args{mode} //= 'user';
1011             }
1012 154         1089 my $dumper = Config::Model::Dumper->new;
1013 154         729 return $dumper->dump_tree( node => $self, %args );
1014             }
1015              
1016 0     0 1 0 sub migrate ($self, @args) {
  0         0  
  0         0  
  0         0  
1017 0         0 $self->init();
1018 0         0 Config::Model::Dumper->new->dump_tree( node => $self, mode => 'full', @args );
1019              
1020 0         0 return $self->needs_save;
1021             }
1022              
1023 2     2 1 1299 sub dump_annotations_as_pod ($self, @args) {
  2         4  
  2         6  
  2         3  
1024 2         7 $self->init();
1025 2         11 my $dumper = Config::Model::DumpAsData->new;
1026 2         13 return $dumper->dump_annotations_as_pod( node => $self, @args );
1027             }
1028              
1029 9     9 1 19005 sub describe ($self, @args) {
  9         14  
  9         21  
  9         14  
1030 9         29 $self->init();
1031              
1032 9         46 my $descriptor = Config::Model::Describe->new;
1033 9         35 return $descriptor->describe( node => $self, @args );
1034             }
1035              
1036 1     1 1 3 sub report ($self, @args) {
  1         2  
  1         4  
  1         2  
1037 1         5 $self->init();
1038 1         16 my $reporter = Config::Model::Report->new;
1039 1         7 return $reporter->report( node => $self );
1040             }
1041              
1042 1     1 1 1668 sub audit ($self, @args) {
  1         5  
  1         2  
  1         2  
1043 1         4 $self->init();
1044 1         15 my $reporter = Config::Model::Report->new;
1045 1         7 return $reporter->report( node => $self, audit => 1 );
1046             }
1047              
1048 27     27 1 45 sub copy_from ($self, @args) {
  27         46  
  27         72  
  27         37  
1049 27         108 my %args = _resolve_arg_shortcut(\@args, 'from');
1050 27   33     145 my $from = $args{from} || croak "copy_from: missing from argument";
1051 27   100     92 my $check = $args{check} || 'yes';
1052 27         197 $logger->debug( "node " . $self->location . " copy from " . $from->location );
1053 27         295 my $dump = $from->dump_tree( check => 'no' );
1054 27         125 return $self->load( step => $dump, check => $check );
1055             }
1056              
1057             # TODO: need Pod::Text attribute -> move that to a role ?
1058             # to translate Pod description to plain text when help is displayed
1059 124     124 1 176 sub get_help ($self, $tag = '', $elt_name = ''){
  124         203  
  124         194  
  124         188  
  124         158  
1060 124 100       261 if ($elt_name) {
1061 79 50       344 if ( $tag !~ /^(summary|description)$/ ) {
1062 0         0 croak "get_help: wrong argument $tag, expected ", "'description' or 'summary'";
1063             }
1064              
1065 79   100     378 return $self->{$tag}{$elt_name} // '';
1066             }
1067 45 100       94 if ($tag) {
1068 44   100     200 return $self->{description}{ $tag } // '';
1069             }
1070 1   50     7 return $self->{model}{class_description} // '';
1071             }
1072              
1073             sub get_info {
1074 2     2 1 5 my $self = shift;
1075              
1076 2         7 my @items = ( 'type: ' . $self->get_type, 'class name: ' . $self->config_class_name, );
1077              
1078 2         8 my @rexp = $self->accept_regexp;
1079 2 50       8 if (@rexp) {
1080 0         0 push @items, 'accept: /^' . join( '$/, /^', @rexp ) . '$/';
1081             }
1082              
1083 2         7 return @items;
1084             }
1085              
1086 9     9 1 10302 sub tree_searcher ($self, @args){
  9         17  
  9         21  
  9         12  
1087 9         109 return Config::Model::TreeSearcher->new( node => $self, @args );
1088             }
1089              
1090 7     7 1 5162 sub apply_fixes ($self, $filter='' ) {
  7         16  
  7         19  
  7         18  
1091             # define leaf call back
1092 138     138   190 my $do_apply = sub ($name) {
  138         403  
  138         214  
1093 138 100       815 return $filter ? $name =~ /$filter/ : 1;
1094 7         39 };
1095              
1096             my $fix_leaf = sub {
1097 127     127   275 my ( $scanner, $data_ref, $node, $element_name, $index, $leaf_object ) = @_;
1098 127 100       257 $leaf_object->apply_fixes if $do_apply->($element_name);
1099 7         38 };
1100              
1101             my $fix_hash = sub {
1102 3     3   9 my ( $scanner, $data_r, $node, $element, @keys ) = @_;
1103              
1104 3 50       9 return unless @keys;
1105              
1106             # leaves must be fixed before the hash, hence the
1107             # calls to scan_hash before apply_fixes
1108 3         9 map { $scanner->scan_hash( $data_r, $node, $element, $_ ) } @keys;
  7         25  
1109              
1110 3 50       10 $node->fetch_element($element)->apply_fixes if $do_apply->($element);
1111 7         32 };
1112              
1113             my $fix_list = sub {
1114 11     11   30 my ( $scanner, $data_r, $node, $element, @keys ) = @_;
1115              
1116 11 100       34 return unless @keys;
1117              
1118 8         21 map { $scanner->scan_list( $data_r, $node, $element, $_ ) } @keys;
  28         85  
1119 8 50       23 $node->fetch_element($element)->apply_fixes if $do_apply->($element);
1120 7         32 };
1121              
1122 7         62 my $scan = Config::Model::ObjTreeScanner->new(
1123             hash_element_cb => $fix_hash,
1124             list_element_cb => $fix_list,
1125             leaf_cb => $fix_leaf,
1126             check => 'no',
1127             );
1128              
1129 7         41 $fix_logger->debug( "apply fix started from ", $self->name );
1130 7         145 $scan->scan_node( undef, $self );
1131 7         51 $fix_logger->trace("apply fix done");
1132 7         251 return $self;
1133             }
1134              
1135 1     1 1 275 sub deep_check ($self, %args){
  1         2  
  1         2  
  1         3  
1136 1         5 $deep_check_logger->trace("called on ".$self->name);
1137              
1138             # no deep_check defined (yet). Note that value check is done when
1139             # storing value (even during initial load, so there's no need to
1140             # force a check.
1141 1     70   26 my $check_leaf = sub { };
1142              
1143             my $check_id = sub {
1144 10     10   25 my ( $scanner, $data_r, $node, $element, @keys ) = @_;
1145              
1146 10         24 $deep_check_logger->trace( "deep check called on from ", $node->name, " elt $element keys @keys" );
1147 10 100       179 return unless @keys;
1148 5         16 $node->fetch_element($element)->deep_check;
1149              
1150 1         7 };
1151              
1152             my $scan = Config::Model::ObjTreeScanner->new(
1153             hash_element_hook => $check_id,
1154             list_element_hook => $check_id,
1155             leaf_cb => $check_leaf,
1156             auto_vivify => $args{auto_vivify},
1157 1         16 check => 'no',
1158             );
1159              
1160 1         4 $deep_check_logger->debug( "deep check started from ", $self->name );
1161 1         28 $scan->scan_node( undef, $self );
1162 1         7 $deep_check_logger->trace("deep check done");
1163 1         39 return;
1164             }
1165              
1166             __PACKAGE__->meta->make_immutable;
1167              
1168             1;
1169              
1170             # ABSTRACT: Class for configuration tree node
1171              
1172             __END__
1173              
1174             =pod
1175              
1176             =encoding UTF-8
1177              
1178             =head1 NAME
1179              
1180             Config::Model::Node - Class for configuration tree node
1181              
1182             =head1 VERSION
1183              
1184             version 2.153
1185              
1186             =head1 SYNOPSIS
1187              
1188             use Config::Model;
1189              
1190             # define configuration tree object
1191             my $model = Config::Model->new;
1192             $model->create_config_class(
1193             name => 'OneConfigClass',
1194             class_description => "OneConfigClass detailed description",
1195              
1196             element => [
1197             [qw/X Y Z/] => {
1198             type => 'leaf',
1199             value_type => 'enum',
1200             choice => [qw/Av Bv Cv/]
1201             }
1202             ],
1203              
1204             status => [ X => 'deprecated' ],
1205             description => [ X => 'X-ray description (can be long)' ],
1206             summary => [ X => 'X-ray' ],
1207              
1208             accept => [
1209             'ip.*' => {
1210             type => 'leaf',
1211             value_type => 'uniline',
1212             summary => 'ip address',
1213             }
1214             ]
1215             );
1216             my $instance = $model->instance (root_class_name => 'OneConfigClass');
1217             my $root = $instance->config_root ;
1218              
1219             # X is not shown below because of its deprecated status
1220             print $root->describe,"\n" ;
1221             # name value type comment
1222             # Y [undef] enum choice: Av Bv Cv
1223             # Z [undef] enum choice: Av Bv Cv
1224              
1225             # add some data
1226             $root->load( steps => 'Y=Av' );
1227              
1228             # add some accepted element, ipA and ipB are created on the fly
1229             $root->load( steps => q!ipA=192.168.1.0 ipB=192.168.1.1"! );
1230              
1231             # show also ip* element created in the last "load" call
1232             print $root->describe,"\n" ;
1233             # name value type comment
1234             # Y Av enum choice: Av Bv Cv
1235             # Z [undef] enum choice: Av Bv Cv
1236             # ipA 192.168.1.0 uniline
1237             # ipB 192.168.1.1 uniline
1238              
1239             =head1 DESCRIPTION
1240              
1241             This class provides the nodes of a configuration tree. When created, a
1242             node object gets a set of rules that defines its properties
1243             within the configuration tree.
1244              
1245             Each node contain a set of elements. An element can contain:
1246              
1247             =over
1248              
1249             =item *
1250              
1251             A leaf element implemented with L<Config::Model::Value>. A leaf can be
1252             plain (unconstrained value) or be strongly typed (values are checked
1253             against a set of rules).
1254              
1255             =item *
1256              
1257             Another node.
1258              
1259             =item *
1260              
1261             A collection of items: a list element, implemented with
1262             L<Config::Model::ListId>. Each item can be another node or a leaf.
1263              
1264             =item *
1265              
1266             A collection of identified items: a hash element, implemented with
1267             L<Config::Model::HashId>. Each item can be another node or a leaf.
1268              
1269             =back
1270              
1271             =head1 Configuration class declaration
1272              
1273             A class declaration is made of the following parameters:
1274              
1275             =over
1276              
1277             =item B<name>
1278              
1279             Mandatory C<string> parameter. This config class name can be used by a node
1280             element in another configuration class.
1281              
1282             =item B<class_description>
1283              
1284             Optional C<string> parameter. This description is used while
1285             generating user interfaces.
1286              
1287             =item B<class>
1288              
1289             Optional C<string> to specify a Perl class to override the default
1290             implementation (L<Config::Model::Node>). This Perl Class B<must>
1291             inherit L<Config::Model::Node>. Use with care.
1292              
1293             =item B<element>
1294              
1295             Mandatory C<list ref> of elements of the configuration class :
1296              
1297             element => [ foo => { type = 'leaf', ... },
1298             bar => { type = 'leaf', ... }
1299             ]
1300              
1301             Element names can be grouped to save typing:
1302              
1303             element => [ [qw/foo bar/] => { type = 'leaf', ... } ]
1304              
1305             See below for details on element declaration.
1306              
1307             =item B<gist>
1308              
1309             String used to construct a summary of the content of a node. This
1310             parameter is used by user interface to show users the gist of the
1311             content of this node. This parameter has no other effect. This string
1312             may contain element values in the form "C<{foo} or {bar}>". When
1313             constructing the gist, C<{foo}> is replaced by the value of element
1314             C<foo>. Likewise for C<{bar}>.
1315              
1316             =item B<level>
1317              
1318             Optional C<list ref> of the elements whose level are different from
1319             default value (C<normal>). Possible values are C<important>, C<normal>
1320             or C<hidden>.
1321              
1322             The level is used to set how configuration data is presented to the
1323             user in browsing mode. C<Important> elements are shown to the user
1324             no matter what. C<hidden> elements are explained with the I<warp>
1325             notion.
1326              
1327             level => [ [qw/X Y/] => 'important' ]
1328              
1329             =item B<status>
1330              
1331             Optional C<list ref> of the elements whose status are different from
1332             default value (C<standard>). Possible values are C<obsolete>,
1333             C<deprecated> or C<standard>.
1334              
1335             Using a deprecated element issues a warning. Using an obsolete
1336             element raises an exception (See L<Config::Model::Exception>.
1337              
1338             status => [ [qw/X Y/] => 'obsolete' ]
1339              
1340             =item B<description>
1341              
1342             Optional C<list ref> of element summaries. These summaries may be used
1343             when generating user interfaces.
1344              
1345             =item B<description>
1346              
1347             Optional C<list ref> of element descriptions. These descriptions may be
1348             used when generating user interfaces.
1349              
1350             =item B<rw_config>
1351              
1352             =item B<config_dir>
1353              
1354             Parameters used to load on demand configuration data.
1355             See L<Config::Model::BackendMgr> for details.
1356              
1357             =item B<accept>
1358              
1359             Optional list of criteria (i.e. a regular expression to match ) to
1360             accept unknown elements. Each criteria has a list of
1361             specification that enable C<Config::Model> to create a model
1362             snippet for the unknown element.
1363              
1364             Example:
1365              
1366             accept => [
1367             'list.*' => {
1368             type => 'list',
1369             cargo => {
1370             type => 'leaf',
1371             value_type => 'string',
1372             },
1373             },
1374             'str.*' => {
1375             type => 'leaf',
1376             value_type => 'uniline'
1377             },
1378             ]
1379              
1380             All C<element> parameters can be used in specifying accepted elements.
1381              
1382             If L<Text::Levenshtein::Damerau> is installed, a warning is issued if an accepted
1383             element is too close to an existing element.
1384              
1385             The parameter C<accept_after> to specify where to insert the accepted element.
1386             This does not change much the behavior of the tree, but helps generate
1387             a more usable user interface.
1388              
1389             Example:
1390              
1391             element => [
1392             'Bug' => { type => 'leaf', value_type => 'uniline' } ,
1393             ]
1394             accept => [
1395             'Bug-.*' => {
1396             value_type => 'uniline',
1397             type => 'leaf'
1398             accept_after => 'Bug' ,
1399             }
1400             ]
1401              
1402             The model snippet above ensures that C<Bug-Debian> is shown right after C<bug>.
1403              
1404             =for html <p>For more information, see <a href="http://ddumont.wordpress.com/2010/05/19/improve-config-upgrade-ep-02-minimal-model-for-opensshs-sshd_config/">this blog</a>.</p>
1405              
1406             =back
1407              
1408             =head1 Element declaration
1409              
1410             =head2 Element type
1411              
1412             Each element is declared with a list ref that contains all necessary
1413             information:
1414              
1415             element => [
1416             foo => { ... }
1417             ]
1418              
1419             This most important information from this hash ref is the mandatory
1420             B<type> parameter. The I<type> type can be:
1421              
1422             =over 8
1423              
1424             =item C<node>
1425              
1426             The element is a node of a tree instantiated from a
1427             configuration class (declared with
1428             L<Config::Model/"create_config_class( ... )">).
1429             See L</"Node element">.
1430              
1431             =item C<warped_node>
1432              
1433             The element is a node whose properties (mostly C<config_class_name>)
1434             can be changed (warped) according to the values of one or more leaf
1435             elements in the configuration tree. See L<Config::Model::WarpedNode>
1436             for details.
1437              
1438             =item C<leaf>
1439              
1440             The element is a scalar value. See L</"Leaf element">
1441              
1442             =item C<hash>
1443              
1444             The element is a collection of nodes or values (default). Each
1445             element of this collection is identified by a string (Just like a regular
1446             hash, except that you can set up constraint of the keys).
1447             See L</"Hash element">
1448              
1449             =item C<list>
1450              
1451             The element is a collection of nodes or values (default). Each element
1452             of this collection is identified by an integer (Just like a regular
1453             perl array, except that you can set up constraint of the keys). See
1454             L</"List element">
1455              
1456             =item C<check_list>
1457              
1458             The element is a collection of values which are unique in the
1459             check_list. See L<CheckList>.
1460              
1461             =item C<class>
1462              
1463             Override the default class for leaf, list and hash elements. The override
1464             class be inherit L<Config::Model::Value> for leaf element,
1465             L<Config::Model::HashId> for hash element and
1466             L<Config::Model::ListId> for list element.
1467              
1468             =back
1469              
1470             =head2 Node element
1471              
1472             When declaring a C<node> element, you must also provide a
1473             C<config_class_name> parameter. For instance:
1474              
1475             $model ->create_config_class
1476             (
1477             name => "ClassWithOneNode",
1478             element => [
1479             the_node => {
1480             type => 'node',
1481             config_class_name => 'AnotherClass',
1482             },
1483             ]
1484             ) ;
1485              
1486             =head2 Leaf element
1487              
1488             When declaring a C<leaf> element, you must also provide a
1489             C<value_type> parameter. See L<Config::Model::Value> for more details.
1490              
1491             =head2 Hash element
1492              
1493             When declaring a C<hash> element, you must also provide a
1494             C<index_type> parameter.
1495              
1496             You can also provide a C<cargo_type> parameter set to C<node> or
1497             C<leaf> (default).
1498              
1499             See L<Config::Model::HashId> and L<Config::Model::AnyId> for more
1500             details.
1501              
1502             =head2 List element
1503              
1504             You can also provide a C<cargo_type> parameter set to C<node> or
1505             C<leaf> (default).
1506              
1507             See L<Config::Model::ListId> and L<Config::Model::AnyId> for more
1508             details.
1509              
1510             =head1 Constructor
1511              
1512             The C<new> constructor accepts the following parameters:
1513              
1514             =over
1515              
1516             =item config_file
1517              
1518             Specify configuration file to be used by backend. This parameter may
1519             override a file declared in the model. Note that this parameter is not
1520             propagated in children nodes.
1521              
1522             =back
1523              
1524             =head1 Introspection methods
1525              
1526             =head2 name
1527              
1528             Returns the location of the node, or its config class name (for root
1529             node).
1530              
1531             =head2 get_type
1532              
1533             Returns C<node>.
1534              
1535             =head2 config_model
1536              
1537             Returns the B<entire> configuration model (L<Config::Model> object).
1538              
1539             =head2 model
1540              
1541             Returns the configuration model of this node (data structure).
1542              
1543             =head2 config_class_name
1544              
1545             Returns the configuration class name of this node.
1546              
1547             =head2 instance
1548              
1549             Returns the instance object containing this node. Inherited from
1550             L<Config::Model::AnyThing>
1551              
1552             =head2 has_element
1553              
1554             Arguments: C<< ( name => element_name, [ type => searched_type ], [ autoadd => 1 ] ) >>
1555              
1556             Returns 1 if the class model has the element declared.
1557              
1558             Returns 1 as well if C<autoadd> is 1 (i.e. by default) and the element
1559             name is matched by the optional C<accept> model parameter.
1560              
1561             If C<type> is specified, the element name must also match the type.
1562              
1563             =head2 find_element
1564              
1565             Parameters: C<< ( element_name , [ case => any ]) >>
1566              
1567             Returns C<$name> if the class model has the element declared or if the element
1568             name is matched by the optional C<accept> parameter.
1569              
1570             If C<case> is set to any, C<has_element> returns the element name who match the passed
1571             name in a case-insensitive manner.
1572              
1573             Returns empty if no matching element is found.
1574              
1575             =head2 model_searcher
1576              
1577             Returns an object dedicated to search an element in the configuration
1578             model.
1579              
1580             This method returns a L<Config::Model::SearchElement> object. See
1581             L<Config::Model::SearchElement> for details on how to handle a search.
1582              
1583             This method is inherited from L<Config::Model::AnyThing>.
1584              
1585             =head2 element_model
1586              
1587             Parameters: C<< ( element_name ) >>
1588              
1589             Returns model of the element.
1590              
1591             =head2 element_type
1592              
1593             Parameters: C<< ( element_name ) >>
1594              
1595             Returns the type (e.g. leaf, hash, list, checklist or node) of the
1596             element. Also returns the type of a potentially accepted element.
1597             Dies if the element is not known or cannot be accepted.
1598              
1599             =head2 element_name
1600              
1601             Returns the element name that contain this object. Inherited from
1602             L<Config::Model::AnyThing>
1603              
1604             =head2 index_value
1605              
1606             See L<Config::Model::AnyThing/"index_value()">
1607              
1608             =head2 parent
1609              
1610             See L<Config::Model::AnyThing/"parent">
1611              
1612             =head2 root
1613              
1614             See L<Config::Model::AnyThing/"root">
1615              
1616             =head2 location
1617              
1618             See L<Config::Model::AnyThing/"location">
1619              
1620             =head2 backend_support_annotation
1621              
1622             Returns 1 if at least one of the backends attached to self or a parent
1623             node support to read and write annotations (aka comments) in the
1624             configuration file.
1625              
1626             =head1 Element property management
1627              
1628             =head2 get_element_names
1629              
1630             Return all available element names, including the element that were accepted.
1631              
1632             Optional parameters are:
1633              
1634             =over
1635              
1636             =item *
1637              
1638             B<all>: Boolean. When set return all element names, even the hidden
1639             ones and does not trigger warp mechanism. Defaults to 0. This option
1640             should be set to 1 when this method is needed to read configuration data from a
1641             backend.
1642              
1643             =item *
1644              
1645             B<type>: Returns only element of requested type (e.g. C<list>,
1646             C<hash>, C<leaf>,...). By default return elements of any type.
1647              
1648             =item *
1649              
1650             B<cargo_type>: Returns only hash or list elements that contain
1651             the requested cargo type.
1652             E.g. if C<get_element_names> is called with C<< cargo_type => 'leaf' >>,
1653             then C<get_element_names> returns hash
1654             or list elements that contain a L<leaf|Config::Model::Value> object.
1655              
1656             =item *
1657              
1658             B<check>: C<yes>, C<no> or C<skip>
1659              
1660             =back
1661              
1662             C<type> and C<cargo_type> parameters can be specified together. In
1663             this case, this method returns parameters that satisfy B<both>
1664             conditions. I.e. with C<< type =>'hash', cargo_type => 'leaf' >>, this
1665             method returns only hash elements that contain leaf objects.
1666              
1667             Returns a list in array context, and a string
1668             (e.g. C<join(' ',@array)>) in scalar context.
1669              
1670             =head2 children
1671              
1672             Like C<get_element_names> without parameters. Returns the list of elements. This method is
1673             polymorphic for all non-leaf objects of the configuration tree.
1674              
1675             =head2 next_element
1676              
1677             This method provides a way to iterate through the elements of a node.
1678             Mandatory parameter is C<name>. Optional parameter: C<status>.
1679              
1680             Returns the next element name for status (default C<normal>).
1681             Returns undef if no next element is available.
1682              
1683             =head2 previous_element
1684              
1685             Parameters: C<< ( name => element_name ) >>
1686              
1687             This method provides a way to iterate through the elements of a node.
1688              
1689             Returns the previous element name. Returns undef if no previous element is available.
1690              
1691             =head2 get_element_property
1692              
1693             Parameters: C<< ( element => ..., property => ... ) >>
1694              
1695             Retrieve a property of an element.
1696              
1697             I.e. for a model :
1698              
1699             status => [ X => 'deprecated' ]
1700             element => [ X => { ... } ]
1701              
1702             This call returns C<deprecated>:
1703              
1704             $node->get_element_property ( element => 'X', property => 'status' )
1705              
1706             =head2 set_element_property
1707              
1708             Parameters: C<< ( element => ..., property => ... ) >>
1709              
1710             Set a property of an element.
1711              
1712             =head2 reset_element_property
1713              
1714             Parameters: C<< ( element => ... ) >>
1715              
1716             Reset a property of an element according to the original model.
1717              
1718             =head1 Information management
1719              
1720             =head2 fetch_element
1721              
1722             Arguments: C<< ( name => .. , [ check => ..], [ autoadd => 1 ] ) >>
1723              
1724             Fetch and returns an element from a node if the class model has the
1725             element declared.
1726              
1727             Also fetch and returns an element from a node if C<autoadd> is 1
1728             (i.e. by default) and the element name is matched by the optional
1729             C<accept> model parameter.
1730              
1731             C<check> can be set to C<yes>, C<no> or C<skip>.
1732             When C<check> is C<no> or C<skip>, this method returns C<undef> when the
1733             element is unknown, or 0 if the element is not available (hidden).
1734              
1735             By default, "accepted" elements are automatically created. Set
1736             C<autoadd> to 0 when this behavior is not wanted.
1737              
1738             =head2 fetch_element_value
1739              
1740             Parameters: C<< ( name => ... [ check => ...] ) >>
1741              
1742             Fetch and returns the I<value> of a leaf element from a node.
1743              
1744             =head2 fetch_gist
1745              
1746             Return the gist of the node. See description of C<gist> parameter above.
1747              
1748             =head2 store_element_value
1749              
1750             Parameters: C<< ( name, value ) >>
1751              
1752             Store a I<value> in a leaf element from a node.
1753              
1754             Can be invoked with named parameters (name, value, check). E.g.
1755              
1756             ( name => 'foo', value => 'bar', check => 'skip' )
1757              
1758             =head2 is_element_available
1759              
1760             Parameters: C<< ( name => ..., ) >>
1761              
1762             Returns 1 if the element C<name> is available and if the element is not "hidden". Returns 0
1763             otherwise.
1764              
1765             As a syntactic sugar, this method can be called with only one parameter:
1766              
1767             is_element_available( 'element_name' ) ;
1768              
1769             =head2 accept_element
1770              
1771             Parameters: C<< ( name ) >>
1772              
1773             Checks and returns the appropriate model of an acceptable element
1774             (i.e. declared as a model C<element> or part of an C<accept> declaration).
1775             Returns undef if the element cannot be accepted.
1776              
1777             =head2 accept_regexp
1778              
1779             Parameters: C<< ( name ) >>
1780              
1781             Returns the list of regular expressions used to check for acceptable parameters.
1782             Useful for diagnostics.
1783              
1784             =head2 element_exists
1785              
1786             Parameters: C<< ( element_name ) >>
1787              
1788             Returns 1 if the element is known in the model.
1789              
1790             =head2 is_element_defined
1791              
1792             Parameters: C<< ( element_name ) >>
1793              
1794             Returns 1 if the element is defined.
1795              
1796             =head2 grab
1797              
1798             See L<Config::Model::Role::Grab/grab">.
1799              
1800             =head2 grab_value
1801              
1802             See L<Config::Model::Role::Grab/grab_value">.
1803              
1804             =head2 grab_root
1805              
1806             See L<Config::Model::Role::Grab/"grab_root">.
1807              
1808             =head2 get
1809              
1810             Parameters: C<< ( path => ..., mode => ... , check => ... , get_obj => 1|0, autoadd => 1|0) >>
1811              
1812             Get a value from a directory like path. If C<get_obj> is 1, C<get> returns a leaf object
1813             instead of returning its value.
1814              
1815             =head2 set
1816              
1817             Parameters: C<< ( path , value) >>
1818              
1819             Set a value from a directory like path.
1820              
1821             =head1 Validation
1822              
1823             =head2 deep_check
1824              
1825             Scan the tree and deep check on all elements that support this. Currently only hash or
1826             list element have this feature.
1827              
1828             =head1 data modification
1829              
1830             =head2 migrate
1831              
1832             Force a read of the configuration and perform all changes regarding
1833             deprecated elements or values. Return 1 if data needs to be saved.
1834              
1835             =head2 apply_fixes
1836              
1837             Scan the tree from this node and apply fixes that are attached to warning specifications.
1838             See C<warn_if_match> or C<warn_unless_match> in L<Config::Model::Value/>. Return C<$self> since v2.151.
1839              
1840             =head2 load
1841              
1842             Parameters: C<< ( steps => string [ ... ]) >>
1843              
1844             Load configuration data from the string into the node and its siblings.
1845              
1846             This string follows the syntax defined in L<Config::Model::Loader>.
1847             See L<Config::Model::Loader/"load"> for details on parameters.
1848              
1849             This method can also be called with a single parameter:
1850              
1851             $node->load("some data:to be=loaded");
1852              
1853             =head2 load_data
1854              
1855             Parameters: C<< ( data => hash_ref, [ check => $check, ... ]) >>
1856              
1857             Load configuration data with a hash ref. The hash ref key must match
1858             the available elements of the node (or accepted element). The hash ref structure must match
1859             the structure of the configuration model.
1860              
1861             Use C<< check => skip >> to make data loading more tolerant: bad data are discarded.
1862              
1863             C<load_data> can be called with a single hash ref parameter.
1864              
1865             Returns 1 if some data were saved (instead of skipped).
1866              
1867             =head2 needs_save
1868              
1869             return 1 if one of the elements of the node's sub-tree has been modified.
1870              
1871             =head1 Serialization
1872              
1873             =head2 dump_tree
1874              
1875             Dumps the configuration data of the node and its siblings into a
1876             string. See L<Config::Model::Dumper/dump_tree> for parameter details.
1877              
1878             This string follows the syntax defined in
1879             L<Config::Model::Loader>. The string produced by C<dump_tree> can be
1880             passed to C<load>.
1881              
1882             =head2 dump_annotations_as_pod
1883              
1884             Dumps the configuration annotations of the node and its siblings into a
1885             string. See L<Config::Model::Dumper/dump_annotations_as_pod> for parameter details.
1886              
1887             =head2 describe
1888              
1889             Parameters: C<< ( [ element => ... ] ) >>
1890              
1891             Provides a description of the node elements or of one element.
1892              
1893             =head2 report
1894              
1895             Provides a text report on the content of the configuration below this
1896             node.
1897              
1898             =head2 audit
1899              
1900             Provides a text audit on the content of the configuration below this
1901             node. This audit shows only value different from their default
1902             value.
1903              
1904             =head2 copy_from
1905              
1906             Parameters: C<< ( from => another_node_object, [ check => ... ] ) >>
1907              
1908             Copy configuration data from another node into this node and its
1909             siblings. The copy can be made in a I<tolerant> mode where invalid data
1910             is discarded with C<< check => skip >>. This method can be called with
1911             a single argument: C<< copy_from($another_node) >>
1912              
1913             =head1 Help management
1914              
1915             =head2 get_help
1916              
1917             Parameters: C<< ( [ [ description | summary ] => element_name ] ) >>
1918              
1919             If called without element, returns the description of the class
1920             (Stored in C<class_description> attribute of a node declaration).
1921              
1922             If called with an element name, returns the description of the
1923             element (Stored in C<description> attribute of a node declaration).
1924              
1925             If called with 2 argument, either return the C<summary> or the
1926             C<description> of the element.
1927              
1928             Returns an empty string if no description was found.
1929              
1930             =head2 get_info
1931              
1932             Returns a list of information related to the node. See
1933             L<Config::Model::Value/get_info> for more details.
1934              
1935             =head2 tree_searcher
1936              
1937             Parameters: C<< ( type => ... ) >>
1938              
1939             Returns an object able to search the configuration tree.
1940             Parameters are :
1941              
1942             =over
1943              
1944             =item type
1945              
1946             Where to perform the search. It can be C<element>, C<value>,
1947             C<key>, C<summary>, C<description>, C<help> or C<all>.
1948              
1949             =back
1950              
1951             Then, C<search> method must then be called on the object returned
1952             by C<tree_searcher>.
1953              
1954             Returns a L<Config::Model::TreeSearcher> object.
1955              
1956             =head2 Lazy load of node data
1957              
1958             As configuration model are getting bigger, the load time of a tree
1959             gets longer. The L<Config::Model::BackendMgr> class provides a way to
1960             load the configuration information only when needed.
1961              
1962             =head1 AUTHOR
1963              
1964             Dominique Dumont, (ddumont at cpan dot org)
1965              
1966             =head1 SEE ALSO
1967              
1968             L<Config::Model>,
1969             L<Config::Model::Instance>,
1970             L<Config::Model::HashId>,
1971             L<Config::Model::ListId>,
1972             L<Config::Model::CheckList>,
1973             L<Config::Model::WarpedNode>,
1974             L<Config::Model::Value>
1975              
1976             =head1 AUTHOR
1977              
1978             Dominique Dumont
1979              
1980             =head1 COPYRIGHT AND LICENSE
1981              
1982             This software is Copyright (c) 2005-2022 by Dominique Dumont.
1983              
1984             This is free software, licensed under:
1985              
1986             The GNU Lesser General Public License, Version 2.1, February 1999
1987              
1988             =cut