File Coverage

blib/lib/Config/Model.pm
Criterion Covered Total %
statement 712 886 80.3
branch 247 392 63.0
condition 116 209 55.5
subroutine 67 74 90.5
pod 15 52 28.8
total 1157 1613 71.7


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 5.20.0;
12 59     59   6147980 use strict ;
  59         713  
13 59     59   294 use warnings;
  59         93  
  59         1053  
14 59     59   258  
  59         96  
  59         1447  
15             use Mouse;
16 59     59   22551 use Mouse::Util::TypeConstraints;
  59         1358865  
  59         212  
17 59     59   20047 use MouseX::StrictConstructor;
  59         137  
  59         215  
18 59     59   27407  
  59         14333  
  59         184  
19             use Carp;
20 59     59   7889 use Storable ('dclone');
  59         106  
  59         3382  
21 59     59   30995 use Data::Dumper ();
  59         157813  
  59         3188  
22 59     59   19686 use Log::Log4perl 1.11 qw(get_logger :levels);
  59         209808  
  59         1523  
23 59     59   33784 use Config::Model::Instance;
  59         1856181  
  59         335  
24 59     59   36764 use Hash::Merge 0.12 qw/merge/;
  59         208  
  59         2832  
25 59     59   26888 use Path::Tiny 0.053;
  59         476736  
  59         3691  
26 59     59   472 use File::HomeDir;
  59         827  
  59         2262  
27 59     59   26576  
  59         270303  
  59         3177  
28             use Cwd;
29 59     59   405 use Config::Model::Lister;
  59         125  
  59         2866  
30 59     59   21256  
  59         140  
  59         2124  
31             with "Config::Model::Role::Constants";
32              
33             use parent qw/Exporter/;
34 59     59   353 our @EXPORT_OK = qw/cme initialize_log4perl/;
  59         117  
  59         491  
35              
36             use feature qw/signatures postderef/;
37 59     59   4531 no warnings qw/experimental::signatures experimental::postderef/;
  59         111  
  59         4876  
38 59     59   328  
  59         128  
  59         713558  
39             # used in some tests where we don't want to load
40             # ~/.log4config-model config
41             my $force_default_log;
42             return $force_default_log = 1;
43 1     1 0 105 }
  1         2  
44 1         2  
45             my $legacy_logger = get_logger("Model::Legacy") ;
46             my $loader_logger = get_logger("Model::Loader") ;
47             my $logger = get_logger("Model") ;
48              
49             # used to keep one Config::Model object to simplify programs based on
50             # cme function
51             my $model_storage;
52              
53             enum LegacyTreament => qw/die warn ignore/;
54              
55             has skip_include => ( isa => 'Bool', is => 'ro', default => 0 );
56             has model_dir => ( isa => 'Str', is => 'ro', default => 'Config/Model/models' );
57             has legacy => ( isa => 'LegacyTreament', is => 'ro', default => 'warn' );
58             has instances => (
59             isa => 'HashRef[Config::Model::Instance]',
60             is => 'ro',
61             default => sub { {} },
62             traits => ['Hash'],
63             handles => {
64             store_instance => 'set',
65             get_instance => 'get',
66             has_instance => 'defined',
67             },
68             );
69              
70             # Config::Model stores 3 versions of each model
71              
72             # raw_model is the model exactly as passed by the user. Since the format is quite
73             # liberal (e.g legacy parameters, grouped declaration of elements like '[qw/foo bar/] => {}}',
74             # element description in class or in element declaration)), this raw format is not
75             # usable without normalization (done by normalize_class_parameters)
76              
77             # the key if this hash is a model name
78             has raw_models => (
79             isa => 'HashRef',
80             is => 'ro',
81             default => sub { {} },
82             traits => ['Hash'],
83             handles => {
84             raw_model_exists => 'exists',
85             raw_model_defined => 'defined',
86             raw_model => 'get',
87             get_raw_model => 'get',
88             store_raw_model => 'set',
89             raw_model_names => 'keys',
90             },
91             );
92              
93             # the result of normalization is stored here. Normalized model aggregate user models and
94             # augmented features (the one found in Foo.d directory). inclusion of other class is NOT
95             # yet done. normalized_models are created while loading files (load method) or creating
96             # configuration classes (create_config_class)
97             has normalized_models => (
98             isa => 'HashRef',
99             is => 'ro',
100             default => sub { {} },
101             traits => ['Hash'],
102             handles => {
103             normalized_model_exists => 'exists',
104             normalized_model_defined => 'defined',
105             normalized_model => 'get',
106             store_normalized_model => 'set',
107             normalized_model_names => 'keys',
108             },
109             );
110              
111             # This attribute contain the model that will be used by Config::Model::Node. They
112             # are created on demand when get_model is called. When created the inclusion of
113             # other classes is done according to the class 'include' parameter. Note that get_model
114             # will try to call load if the required normalized_model is not known (lazy loading)
115             has models => (
116             isa => 'HashRef',
117             is => 'ro',
118             default => sub { {} },
119             traits => ['Hash'],
120             handles => {
121             model_exists => 'exists',
122             model_defined => 'defined',
123             _get_model => 'get',
124             _store_model => 'set',
125             },
126             );
127              
128             # model snippet may be loaded when the target class is not available
129             # so they must be stored before being used.
130             has model_snippets => (
131             isa => 'ArrayRef',
132             is => 'ro',
133             default => sub { [] },
134             traits => ['Array'],
135             handles => {
136             add_snippet => 'push',
137             all_snippets => 'elements',
138             },
139             );
140              
141              
142             enum 'LOG_LEVELS', [ qw/ERROR WARN INFO DEBUG TRACE/ ];
143              
144             has log_level => (
145             isa => 'LOG_LEVELS',
146             is => 'ro',
147             );
148              
149             has skip_inheritance => (
150             isa => 'Bool',
151             is => 'ro',
152             default => 0,
153             trigger => sub {
154             my $self = shift;
155             $self->show_legacy_issue("skip_inheritance is deprecated, use skip_include");
156             $self->skip_include = $self->skip_inheritance;
157             } );
158              
159             # remove this hack mid 2022
160             around BUILDARGS => sub ($orig, $class, %args) {
161             my %new;
162             foreach my $k (keys %args) {
163             if (defined $args{$k}) {
164             $new{$k} = $args{$k};
165             }
166             else {
167             # cannot use logger, it's not initialised yet
168             croak("Config::Model new: passing undefined constructor argument is deprecated ($k argument)\n");
169             }
170             }
171              
172             return $class->$orig(%new);
173             };
174              
175             # keep this as a separate sub from BUILD. So user can call it before
176             # creating Config::Model object
177             if (ref $args[0]) {
178             # may be called as $self-> initialize_log4perl
179 41     41 1 8369 shift @args;
  41         141  
  41         88  
180 41 50       134 }
181              
182 0         0 my %args = @args;
183              
184             my $log4perl_syst_conf_file = path('/etc/log4config-model.conf');
185 41         137 # avoid undef warning when homedir is not defined (e.g. with Debian cowbuilder)
186             my $home = File::HomeDir->my_home // '';
187 41         221 my $log4perl_user_conf_file = path( $home . '/.log4config-model' );
188              
189 41   50     2038 my $fallback_conf_file = path($INC{"Config/Model.pm"})
190 41         3876 ->parent->child("Model/log4perl.conf") ;
191              
192 41         1153  
193             my $log4perl_file =
194             $force_default_log ? $fallback_conf_file # for tests
195             : $log4perl_user_conf_file->is_file ? $log4perl_user_conf_file
196 41 50       6120 : $log4perl_syst_conf_file->is_file ? $log4perl_syst_conf_file
    50          
    100          
197             : $fallback_conf_file;
198             my %log4perl_conf =
199             map { split /\s*=\s*/,$_,2; }
200             grep { chomp; ! /^\s*#/ } $log4perl_file->lines;
201              
202 1107         2792 my $verbose = $args{verbose};
203 41         1170 if (defined $verbose) {
  1353         10576  
  1353         2166  
204             my @loggers = ref $verbose ? @$verbose : $verbose;
205 41         230 foreach my $logger (@loggers) {
206 41 100       200 $log4perl_conf{"log4perl.logger.Verbose.$logger"} = "INFO, PlainMsgOnScreen";
207 2 100       10 }
208 2         6 }
209 3         10  
210             Log::Log4perl::init(\%log4perl_conf);
211              
212             return \%log4perl_conf; # for tests
213 41         310 }
214              
215 41         850204 my $self = shift;
216             my $args = shift;
217             initialize_log4perl(verbose => $args->{verbose}) unless Log::Log4perl->initialized();
218             return;
219 72     72 1 177 }
220 72         147  
221 72 100       620 my $self = shift;
222 72         799 my $ref = shift;
223             my $behavior = shift || $self->legacy;
224              
225             my @msg = ref $ref ? @$ref : $ref;
226 1     1 0 2 unshift @msg, "Model ";
227 1         2 if ( $behavior eq 'die' ) {
228 1   33     4 die @msg, "\n";
229             }
230 1 50       5 elsif ( $behavior eq 'warn' ) {
231 1         4 $legacy_logger->warn(@msg);
232 1 50       7 } elsif ( $behavior eq 'note' ) {
    50          
    0          
233 0         0 $legacy_logger->info( @msg);
234             }
235             return;
236 1         6 }
237              
238 0         0 my ($args) = @_ ;
239              
240 1         10 my $application = $args->{application} ;
241             my $cat = '';
242             if (defined $application) {
243             my ( $categories, $appli_info, $appli_map ) = Config::Model::Lister::available_models;
244 141     141   336  
245             # root_class_name may override class found (or not) by appli in tests
246 141         366 if (not $args->{root_class_name}) {
247 141         293 $args->{root_class_name} = $appli_map->{$application} ||
248 141 100       495 die "Unknown application $application. Expected one of "
249 46         230 . join(' ',sort keys %$appli_map)."\n";
250             }
251              
252 46 100       178 $cat = $appli_info->{_category} // ''; # may be empty in tests
253 5   50     26 # config_dir may be specified in application file
254             $args->{config_dir} //= $appli_info->{$application}{config_dir};
255             $args->{appli_info} = $appli_info->{$application} // {};
256             }
257              
258 46   50     230 my $app_name = $application;
259             if ($cat eq 'application') {
260 46   33     265 # store dir in name to distinguish different runs of the same
261 46   50     360 # app in different directories.
262             $application .= " in " . cwd;
263             }
264 141         273 $args->{name}
265 141 50       474 = delete $args->{instance_name} # backward compat with test
266             || delete $args->{name} # preferred parameter
267             || $app_name # fallback in most cases
268 0         0 || 'default'; # fallback mostly in tests
269             return;
270             }
271              
272             my %args = @args == 1 ? ( application => $args[0]) : @args ;
273 141   100     669  
274             if (my $force = delete $args{'force-load'}) {
275 141         320 $args{check} = 'no' if $force;
276             }
277              
278 5     5 1 66267 my $cat =_tweak_instance_args(\%args);
  5         23  
  5         11  
279 5 100       40  
280             my $m_args = delete $args{model_args} // {} ; # used for tests
281 5 100       35 # model_storage is used to keep Config::Model object alive
282 1 50       10 $model_storage //= Config::Model->new(%$m_args);
283              
284             return $model_storage->instance(%args);
285 5         21 }
286              
287 5   50     25 my %args = @args == 1 ? ( application => $args[0]) : @args ;
288              
289 5   66     95 # also creates a default name
290             _tweak_instance_args(\%args);
291 5         89  
292             if ( $args{name} and $self->has_instance($args{name}) ) {
293             return $self->get_instance($args{name});
294 136     136 1 608323 }
  136         342  
  136         515  
  136         244  
295 136 50       903  
296             croak "Model: can't create instance without application or root_class_name "
297             unless $args{root_class_name};
298 136         656  
299             if ( defined $args{model_file} ) {
300 136 100 66     1023 my $file = delete $args{model_file};
301 4         75 $self->load( $args{root_class_name}, $file );
302             }
303              
304             my $i = Config::Model::Instance->new(
305 132 50       2082 config_model => $self,
306             %args # for optional parameters like *directory
307 132 100       396 );
308 15         32  
309 15         161 $self->store_instance($args{name}, $i);
310             return $i;
311             }
312 132         3829  
313             my $self = shift;
314             my @all = sort keys %{ $self->instances };
315             return @all;
316             }
317 132         3535  
318 132         6071 # unpacked model is:
319             # {
320             # element_list => [ ... ],
321             # element => { element_name => element_data (left as is) },
322 0     0 0 0 # class_description => <class description string>,
323 0         0 # include => 'class_name',
  0         0  
324 0         0 # include_after => 'element_name',
325             # }
326             # description, summary, level, status are moved
327             # into element description.
328              
329             my @legal_params_to_move = (
330             qw/read_config write_config rw_config/, # read/write stuff
331              
332             # this parameter is filled by class generated by a program. It may
333             # be used to avoid interactive edition of a generated model
334             'generated_by',
335             qw/class_description author copyright gist license include include_after include_backend class/
336             );
337              
338             my @other_legal_params = qw/ author element status description summary level accept/;
339              
340             # keep as external API. All internal call go through _store_model
341             # See comments around raw_models attribute for explanations
342             my $config_class_name = delete $raw_model{name}
343             or croak "create_config_class: no config class name";
344              
345             get_logger("Model")->info("Creating class $config_class_name");
346              
347             if ( $self->model_exists($config_class_name) ) {
348             Config::Model::Exception::ModelDeclaration->throw(
349             error => "create_config_class: attempt to clobber $config_class_name"
350             . " config class name " );
351 96     96 1 522715 }
  96         189  
  96         313  
  96         157  
352              
353 96 50       381 $self->store_raw_model( $config_class_name, dclone( \%raw_model ) );
354              
355 96         345 my $model = $self->normalize_class_parameters( $config_class_name, \%raw_model );
356              
357 96 50       3901 $self->store_normalized_model( $config_class_name, $model );
358 0         0  
359             return $config_class_name;
360             }
361              
362             my ( $self, $config_class_name ) = @_;
363 96         7907  
364             my $normalized_model = $self->normalized_model($config_class_name);
365 96         3936 my $model = dclone $normalized_model ;
366              
367 95         398 # add included elements
368             if ( $self->skip_include and defined $normalized_model->{include} ) {
369 95         3180 my $inc = $normalized_model->{include};
370             $model->{include} = ref $inc ? $inc : [$inc];
371             $model->{include_after} = $normalized_model->{include_after}
372             if defined $normalized_model->{include_after};
373 245     245 0 556 }
374             else {
375 245         756 # include class in raw_copy, normalized_model is left as is
376 245         17633 $self->include_class( $config_class_name, $model );
377             }
378              
379 245 50 33     1648 # add included backend
380 0         0 if ( $self->skip_include and defined $normalized_model->{include_backend} ) {
381 0 0       0 my $inc = $normalized_model->{include_backend};
382             $model->{include_backend} = ref $inc ? $inc : [$inc];
383 0 0       0 }
384             else {
385             # include read/write config specifications in raw_copy,
386             # normalized_model is left as is
387 245         1012 $self->include_backend( $config_class_name, $model );
388             }
389              
390             return $model;
391 244 50 33     947 }
392 0         0  
393 0 0       0 my $self = shift;
394             my $class_name = shift || croak "include_backend: undef includer";
395             my $target_model = shift || die "include_backend:: undefined target_model";
396              
397             my $included_classes = delete $target_model->{include_backend};
398 244         728 return () unless defined $included_classes;
399              
400             foreach my $included_class (@$included_classes) {
401 244         463 # takes care of recursive include, because get_model will perform
402             # includes (and normalization). Is already a dclone
403             my $included_model = $self->get_model_clone($included_class);
404              
405 244     244 1 393 foreach my $rw (qw/rw_config read_config write_config config_dir/) {
406 244   33     538 if ($target_model->{$rw} and $included_model->{$rw}) {
407 244   50     556 my $msg = "Included $rw from $included_class cannot clobber "
408             . "existing data in $class_name";
409 244         407 Config::Model::Exception::ModelDeclaration->throw( error => $msg );
410 244 100       598 }
411             elsif ($included_model->{$rw}) {
412 1         3 $target_model->{$rw} = $included_model->{$rw};
413             }
414             }
415 1         3 }
416             return;
417 1         44 }
418 4 50 33     18  
    100          
419 0         0 my $self = shift;
420             my $config_class_name = shift || die;
421 0         0 my $normalized_model = shift || die;
422              
423             my $model = {};
424 1         3  
425             # sanity check
426             my $raw_name = delete $normalized_model->{name};
427             if ( defined $raw_name and $config_class_name ne $raw_name ) {
428 1         3 my $e = "internal: config_class_name $config_class_name ne model name $raw_name";
429             Config::Model::Exception::ModelDeclaration->throw( error => $e );
430             }
431              
432 376     376 0 590 my @element_list;
433 376   50     805  
434 376   50     798 # first construct the element list
435             my @compact_list = @{ $normalized_model->{element} || [] };
436 376         592 while (@compact_list) {
437             my ( $item, $info ) = splice @compact_list, 0, 2;
438              
439 376         713 # store the order of element as declared in 'element'
440 376 50 66     1247 push @element_list, ref($item) ? @$item : ($item);
441 0         0 }
442 0         0  
443             if ( defined $normalized_model->{inherit_after} ) {
444             $self->show_legacy_issue([ "Model $config_class_name: inherit_after is deprecated ",
445 376         485 "in favor of include_after" ]);
446             $normalized_model->{include_after} = delete $normalized_model->{inherit_after};
447             }
448 376 100       461 if ( defined $normalized_model->{inherit} ) {
  376         1255  
449 376         816 $self->show_legacy_issue(
450 1237         1975 "Model $config_class_name: inherit is deprecated in favor of include");
451             $normalized_model->{include} = delete $normalized_model->{inherit};
452             }
453 1237 100       2892  
454             foreach my $info (@legal_params_to_move) {
455             next unless defined $normalized_model->{$info};
456 376 50       833 $model->{$info} = delete $normalized_model->{$info};
457 0         0 }
458              
459 0         0 # first deal with perl file and cds_file backend
460             $self->translate_legacy_backend_info( $config_class_name, $model );
461 376 50       723  
462 0         0 # handle accept parameter
463             my @accept_list;
464 0         0 my %accept_hash;
465             my $accept_info = delete $normalized_model->{'accept'} || [];
466             while (@$accept_info) {
467 376         660 my $name_match = shift @$accept_info; # should be a regexp
468 4888 100       7357  
469 349         759 # handle legacy
470             if ( ref $name_match ) {
471             my $implicit = defined $name_match->{name_match} ? '' : 'implicit ';
472             unshift @$accept_info, $name_match; # put data back in list
473 376         1104 $name_match = delete $name_match->{name_match} || '.*';
474             $logger->warn("class $config_class_name: name_match ($implicit$name_match)",
475             " in accept is deprecated");
476 376         530 }
477              
478 376   100     1255 push @accept_list, $name_match;
479 376         810 $accept_hash{$name_match} = shift @$accept_info;
480 46         75 }
481              
482             $model->{accept} = \%accept_hash;
483 46 50       80 $model->{accept_list} = \@accept_list;
484 0 0       0  
485 0         0 # check for duplicate in @element_list.
486 0   0     0 my %check_list;
487 0         0 foreach (@element_list) { $check_list{$_}++ };
488             my @extra = grep { $check_list{$_} > 1 } keys %check_list;
489             if (@extra) {
490             Config::Model::Exception::ModelDeclaration->throw(
491 46         73 error => "class $config_class_name: @extra element "
492 46         109 . "is declared more than once. Check the included parts" );
493             }
494              
495 376         748 $self->handle_experience_permission( $config_class_name, $normalized_model );
496 376         622  
497             # element is handled first
498             foreach my $info_name (qw/element status description summary level/) {
499 376         501 my $raw_compact_info = delete $normalized_model->{$info_name};
500 376         583  
  1601         2978  
501 376         921 next unless defined $raw_compact_info;
  1601         2539  
502 376 50       821  
503 0         0 Config::Model::Exception::ModelDeclaration->throw(
504             error => "Data for parameter $info_name of $config_class_name"
505             . " is not an array ref" )
506             unless ref($raw_compact_info) eq 'ARRAY';
507              
508 376         1026 my @raw_info = @$raw_compact_info;
509             while (@raw_info) {
510             my ( $item, $info ) = splice @raw_info, 0, 2;
511 376         633 my @element_names = ref($item) ? @$item : ($item);
512 1880         2473  
513             # move element informations (handled first)
514 1880 100       2951 if ( $info_name eq 'element' ) {
515              
516 401 50       928 # warp can be found only in element item
517             $self->translate_legacy_info( $config_class_name, $element_names[0], $info );
518              
519             $self->handle_experience_permission( $config_class_name, $info );
520              
521 401         820 # copy in element data *after* legacy translation
522 401         718 foreach (@element_names) { $model->{element}{$_} = dclone($info); };
523 1324         2872 }
524 1324 100       2733  
525             # move some information into element declaration (without clobberring)
526             elsif ( $info_name =~ /description|level|summary|status/ ) {
527 1324 100       2486 foreach (@element_names) {
    50          
528             Config::Model::Exception::ModelDeclaration->throw(
529             error => "create class $config_class_name: '$info_name' "
530 1237         2797 . "declaration for non declared element '$_'" )
531             unless defined $model->{element}{$_};
532 1237         2302  
533             $model->{element}{$_}{$info_name} ||= $info;
534             }
535 1237         1735 }
  1601         26331  
536             else {
537             die "Unexpected element $item in $config_class_name model";
538             }
539              
540 87         155 }
541             }
542              
543             Config::Model::Exception::ModelDeclaration->throw(
544 151 100       328 error => "create class $config_class_name: unexpected "
545             . "parameters '"
546 150   33     545 . join( ', ', sort keys %$normalized_model ) . "' "
547             . "Expected '"
548             . join( "', '", @legal_params_to_move, @other_legal_params )
549             . "'" )
550 0         0 if keys %$normalized_model;
551              
552             $model->{element_list} = \@element_list;
553              
554             return $model;
555             }
556              
557 375 50       881 my ( $self, $config_class_name, $model ) = @_;
558              
559             if (delete $model->{permission}) {
560             die "$config_class_name: parameter permission is obsolete\n";
561             }
562             if (delete $model->{experience}) {
563             carp "experience parameter is deprecated";
564             }
565 375         730 return;
566             }
567 375         1086  
568             my $self = shift;
569             my $config_class_name = shift || die;
570             my $elt_name = shift;
571 1842     1842 0 2553 my $info = shift;
572              
573 1842 50       2885 $self->translate_warped_node_info( $config_class_name, $elt_name, 'warped_node', $info );
574 0         0  
575             #translate legacy warp information
576 1842 50       2712 if ( defined $info->{warp} ) {
577 0         0 $self->translate_warp_info( $config_class_name, $elt_name, $info->{type}, $info->{warp} );
578             }
579 1842         2156  
580             $self->translate_cargo_info( $config_class_name, $elt_name, $info );
581              
582             if ( defined $info->{cargo}
583 1237     1237 0 1510 && defined $info->{cargo}{type}
584 1237   50     1965 && $info->{cargo}{type} eq 'warped_node' ) {
585 1237         1457 $self->translate_warped_node_info( $config_class_name, $elt_name, 'warped_node', $info->{cargo} );
586 1237         1323 }
587              
588 1237         2657 if ( defined $info->{cargo}
589             and defined $info->{cargo}{warp} ) {
590             $self->translate_warp_info(
591 1237 100       2165 $config_class_name, $elt_name,
592 116         341 $info->{cargo}{type},
593             $info->{cargo}{warp} );
594             }
595 1237         2557  
596             # compute cannot be warped
597 1237 100 66     3274 if ( defined $info->{compute} ) {
      100        
598             $self->translate_compute_info( $config_class_name, $elt_name, $info, 'compute' );
599             $self->translate_allow_compute_override( $config_class_name, $elt_name, $info );
600 2         10 }
601             if ( defined $info->{cargo}
602             and defined $info->{cargo}{compute} ) {
603 1237 100 100     2592 $self->translate_compute_info( $config_class_name, $elt_name, $info->{cargo}, 'compute' );
604             $self->translate_allow_compute_override( $config_class_name, $elt_name, $info->{cargo} );
605             }
606              
607             # refer_to cannot be warped
608 3         18 if ( defined $info->{refer_to} ) {
609             $self->translate_compute_info( $config_class_name, $elt_name, $info,
610             refer_to => 'computed_refer_to' );
611             }
612 1237 100       2073 if ( defined $info->{cargo}
613 32         69 and defined $info->{cargo}{refer_to} ) {
614 32         57 $self->translate_compute_info( $config_class_name, $elt_name,
615             $info->{cargo}, refer_to => 'computed_refer_to' );
616 1237 100 100     2451 }
617              
618 2         7 # translate id default param
619 2         6 # default cannot be stored in cargo since is applies to the id itself
620             if ( defined $info->{type}
621             and ( $info->{type} eq 'list' or $info->{type} eq 'hash' ) ) {
622             if ( defined $info->{default} ) {
623 1237 100       1923 $self->translate_id_default_info( $config_class_name, $elt_name, $info );
624 55         160 }
625             if ( defined $info->{auto_create} ) {
626             $self->translate_id_auto_create( $config_class_name, $elt_name, $info );
627 1237 100 100     2421 }
628             $self->translate_id_min_max( $config_class_name, $elt_name, $info );
629             $self->translate_id_names( $config_class_name, $elt_name, $info );
630 3         8 if ( defined $info->{warp} ) {
631             my $rules_a = $info->{warp}{rules};
632             my %h = @$rules_a;
633             foreach my $rule_effect ( values %h ) {
634             $self->translate_id_names( $config_class_name, $elt_name, $rule_effect );
635 1237 100 100     4607 $self->translate_id_min_max( $config_class_name, $elt_name, $rule_effect );
      100        
636             next unless defined $rule_effect->{default};
637 306 50       565 $self->translate_id_default_info( $config_class_name, $elt_name, $rule_effect );
638 0         0 }
639             }
640 306 50       512 $self->translate_id_class($config_class_name, $elt_name, $info );
641 0         0 }
642              
643 306         726 if ( defined $info->{type} and ( $info->{type} eq 'leaf' ) ) {
644 306         686 $self->translate_legacy_builtin( $config_class_name, $info, $info, );
645 306 100       535 }
646 6         12  
647 6         19 if ( defined $info->{type} and ( $info->{type} eq 'check_list' ) ) {
648 6         14 $self->translate_legacy_built_in_list( $config_class_name, $info, $info, );
649 12         24 }
650 12         23  
651 12 50       30 $legacy_logger->debug(
652 0         0 Data::Dumper->Dump( [$info], [ 'translated_' . $elt_name ] )
653             ) if $legacy_logger->is_debug;
654             return;
655 306         616 }
656              
657             my ( $self, $config_class_name, $model ) = @_;
658 1237 100 100     3345  
659 681         1335 # trap multi backend and change array spec into single spec
660             foreach my $config (qw/read_config write_config/) {
661             my $ref = $model->{$config};
662 1237 100 100     3300 if ($ref and ref($ref) eq 'ARRAY') {
663 63         215 if (@$ref == 1) {
664             $model->{$config} = $ref->[0];
665             }
666             elsif (@$ref > 1){
667 1237 50       2227 $self->show_legacy_issue("$config_class_name $config: multiple backends are obsolete. You now must use only one backend.", 'die');
668             }
669 1237         5072 }
670             }
671              
672             # move read_config spec in re_config
673 376     376 0 668 if ($model->{read_config}) {
674             $self->show_legacy_issue("$config_class_name: read_config specification is deprecated, please move in rw_config", 'warn');
675             $model->{rw_config} = delete $model->{read_config};
676 376         597 }
677 752         967  
678 752 50 33     2090 # merge write_config spec in rw_config
679 0 0       0 if ($model->{write_config}) {
    0          
680 0         0 $self->show_legacy_issue("$config_class_name: write_config specification is deprecated, please merge with read_config and move in rw_config", 'warn');
681             foreach (keys %{$model->{write_config}}) {
682             $model->{rw_config}{$_} = $model->{write_config}{$_}
683 0         0 }
684             delete $model->{write_config};
685             }
686              
687             my $ref = $model->{'rw_config'} || return;
688              
689 376 50       801 die "undefined backend in rw_config spec of class $config_class_name\n" unless $ref->{backend} ;
690 0         0  
691 0         0 if ($ref->{backend} eq 'custom') {
692             my $msg = "$config_class_name: custom read/write backend is obsolete."
693             ." Please replace with a backend inheriting Config::Model::Backend::Any";
694             $self->show_legacy_issue( $msg, 'die');
695 376 50       677 }
696 0         0  
697 0         0 if ( $ref->{backend} =~ /^(perl|ini|cds)$/ ) {
  0         0  
698 0         0 my $backend = $ref->{backend};
699             $self->show_legacy_issue("$config_class_name: deprecated backend '$backend'. Should be '$ {backend}_file'", 'warn');
700 0         0 $ref->{backend} .= "_file";
701             }
702              
703 376   100     805 if ( defined $ref->{allow_empty} ) {
704             $self->show_legacy_issue("$config_class_name: backend $ref->{backend}: allow_empty is deprecated. Use auto_create", 'warn');
705 105 50       219 $ref->{auto_create} = delete $ref->{allow_empty};
706             }
707 105 50       209 return;
708 0         0 }
709              
710 0         0 my $self = shift;
711             my $config_class_name = shift;
712             my $elt_name = shift;
713 105 100       440 my $info = shift;
714 1         3  
715 1         9 my $c_type = delete $info->{cargo_type};
716 1         2 return unless defined $c_type;
717             $self->show_legacy_issue("$config_class_name->$elt_name: parameter cargo_type is deprecated.");
718             my %cargo;
719 105 50       200  
720 0         0 if ( defined $info->{cargo_args} ) {
721 0         0 %cargo = %{ delete $info->{cargo_args} };
722             $self->show_legacy_issue(
723 105         146 "$config_class_name->$elt_name: parameter cargo_args is deprecated.");
724             }
725              
726             $cargo{type} = $c_type;
727 1237     1237 0 1397  
728 1237         1323 if ( defined $info->{config_class_name} ) {
729 1237         1329 $cargo{config_class_name} = delete $info->{config_class_name};
730 1237         1298 $self->show_legacy_issue([
731             "$config_class_name->$elt_name: parameter config_class_name is ",
732 1237         1521 "deprecated. This one must be specified within cargo. ",
733 1237 50       2128 "Ie. cargo=>{config_class_name => 'FooBar'}"
734 0         0 ]);
735 0         0 }
736              
737 0 0       0 $info->{cargo} = \%cargo;
738 0         0 $legacy_logger->debug(
  0         0  
739 0         0 Data::Dumper->Dump( [$info], [ 'translated_' . $elt_name ] )
740             ) if $legacy_logger->is_debug;
741             return;
742             }
743 0         0  
744             my $self = shift;
745 0 0       0 my $config_class_name = shift;
746 0         0 my $elt_name = shift;
747 0         0 my $info = shift;
748             $self->translate_name( $config_class_name, $elt_name, $info, 'allow', 'allow_keys', 'die' );
749             $self->translate_name( $config_class_name, $elt_name, $info, 'allow_from', 'allow_keys_from', 'die' );
750             $self->translate_name( $config_class_name, $elt_name, $info, 'follow', 'follow_keys_from', 'die' );
751             return;
752             }
753              
754 0         0 my ($self, $config_class_name, $elt_name, $info, $from, $to, $legacy) = @_;
755 0 0       0  
756             if ( defined $info->{$from} ) {
757             $self->show_legacy_issue(
758 0         0 "$config_class_name->$elt_name: parameter $from is deprecated in favor of $to",
759             $legacy
760             );
761             $info->{$to} = delete $info->{$from};
762 318     318 0 444 }
763 318         389 return;
764 318         384 }
765 318         360  
766 318         725 my $self = shift;
767 318         634 my $config_class_name = shift;
768 318         607 my $elt_name = shift;
769 318         349 my $info = shift;
770              
771             if ( defined $info->{allow_compute_override} ) {
772             $self->show_legacy_issue(
773 954     954 0 1484 "$config_class_name->$elt_name: parameter allow_compute_override is deprecated in favor of compute -> allow_override"
774             );
775 954 50       1460 $info->{compute}{allow_override} = delete $info->{allow_compute_override};
776 0         0 }
777             return;
778             }
779              
780 0         0 my $self = shift;
781             my $config_class_name = shift;
782 954         1112 my $elt_name = shift;
783             my $info = shift;
784             my $old_name = shift;
785             my $new_name = shift || $old_name;
786 34     34 0 44  
787 34         38 if ( ref( $info->{$old_name} ) eq 'ARRAY' ) {
788 34         40 my $compute_info = delete $info->{$old_name};
789 34         37 $legacy_logger->debug(
790             "translate_compute_info $elt_name input:\n",
791 34 50       57 Data::Dumper->Dump( [$compute_info], [qw/compute_info/] )
792 0         0 ) if $legacy_logger->is_debug;
793              
794             $self->show_legacy_issue([ "$config_class_name->$elt_name: specifying compute info with ",
795 0         0 "an array ref is deprecated" ]);
796              
797 34         42 my ( $user_formula, %var ) = @$compute_info;
798             my $replace_h;
799             foreach ( keys %var ) { $replace_h = delete $var{$_} if ref( $var{$_} ) };
800              
801 92     92 0 140 # cleanup user formula
802 92         121 $user_formula =~ s/\$(\w+)\{/\$replace{/g;
803 92         134  
804 92         118 # cleanup variable
805 92         130 foreach ( values %var ) { s/\$(\w+)\{/\$replace{/g };
806 92   66     213  
807             # change the hash *in* the info structure
808 92 50       225 $info->{$new_name} = {
809 0         0 formula => $user_formula,
810 0 0       0 variables => \%var,
811             };
812             $info->{$new_name}{replace} = $replace_h if defined $replace_h;
813              
814             $legacy_logger->debug(
815 0         0 "translate_warp_info $elt_name output:\n",
816             Data::Dumper->Dump( [ $info->{$new_name} ], [ 'new_' . $new_name ] )
817             ) if $legacy_logger->is_debug;
818 0         0 }
819 0         0 return;
820 0 0       0 }
  0         0  
821              
822             my $self = shift;
823 0         0 my $config_class_name = shift || die;
824             my $elt_name = shift;
825             my $info = shift;
826 0         0  
  0         0  
827              
828             $legacy_logger->debug(
829 0         0 "translate_id_class $elt_name input:\n",
830             Data::Dumper->Dump( [$info], [qw/info/] )
831             ) if $legacy_logger->is_debug;
832              
833 0 0       0 my $class_overide_param = $info->{type}.'_class';
834             my $class_overide = $info->{$class_overide_param};
835             if ($class_overide) {
836             $info->{class} = $class_overide;
837 0 0       0 $self->show_legacy_issue([
838             "$config_class_name->$elt_name: '$class_overide_param' is deprecated, ",
839             "Use 'class' instead."
840 92         137 ]);
841             }
842              
843             $legacy_logger->debug(
844 306     306 0 384 "translate_id_class $elt_name output:",
845 306   50     536 Data::Dumper->Dump( [$info], [qw/new_info/])
846 306         366 ) if $legacy_logger->is_debug;
847 306         352 return;
848             }
849              
850 306 50       589 # internal: translate default information for id element
851             my $self = shift;
852             my $config_class_name = shift || die;
853             my $elt_name = shift;
854             my $info = shift;
855 306         1576  
856 306         412 $legacy_logger->debug(
857 306 50       517 "translate_id_default_info $elt_name input:\n",
858 0         0 Data::Dumper->Dump( [$info], [qw/info/] )
859 0         0 ) if $legacy_logger->is_debug;
860              
861             my $warn = "$config_class_name->$elt_name: 'default' parameter for list or "
862             . "hash element is deprecated. ";
863              
864             my $def_info = delete $info->{default};
865             if ( ref($def_info) eq 'HASH' ) {
866 306 50       551 $info->{default_with_init} = $def_info;
867             $self->show_legacy_issue([ $warn, "Use default_with_init" ]);
868             }
869 306         1358 elsif ( ref($def_info) eq 'ARRAY' ) {
870             $info->{default_keys} = $def_info;
871             $self->show_legacy_issue([ $warn, "Use default_keys" ]);
872             }
873             else {
874 0     0 0 0 $info->{default_keys} = [$def_info];
875 0   0     0 $self->show_legacy_issue([ $warn, "Use default_keys" ]);
876 0         0 }
877 0         0  
878             $legacy_logger->debug(
879 0 0       0 "translate_id_default_info $elt_name output:",
880             Data::Dumper->Dump( [$info], [qw/new_info/])
881             ) if $legacy_logger->is_debug;
882             return;
883             }
884 0         0  
885             # internal: translate auto_create information for id element
886             my $self = shift;
887 0         0 my $config_class_name = shift || die;
888 0 0       0 my $elt_name = shift;
    0          
889 0         0 my $info = shift;
890 0         0  
891             $legacy_logger->debug(
892             "translate_id_auto_create $elt_name input:",
893 0         0 Data::Dumper->Dump( [$info], [qw/info/] )
894 0         0 ) if $legacy_logger->is_debug;
895              
896             my $warn = "$config_class_name->$elt_name: 'auto_create' parameter for list or "
897 0         0 . "hash element is deprecated. ";
898 0         0  
899             my $ac_info = delete $info->{auto_create};
900             if ( $info->{type} eq 'hash' ) {
901 0 0       0 $info->{auto_create_keys} =
902             ref($ac_info) eq 'ARRAY' ? $ac_info : [$ac_info];
903             $self->show_legacy_issue([ $warn, "Use auto_create_keys" ]);
904             }
905 0         0 elsif ( $info->{type} eq 'list' ) {
906             $info->{auto_create_ids} = $ac_info;
907             $self->show_legacy_issue([ $warn, "Use auto_create_ids" ]);
908             }
909             else {
910 0     0 0 0 die "Unexpected element ($elt_name) type $info->{type} ", "for translate_id_auto_create";
911 0   0     0 }
912 0         0  
913 0         0 $legacy_logger->debug(
914             "translate_id_default_info $elt_name output:\n",
915 0 0       0 Data::Dumper->Dump( [$info], [qw/new_info/] )
916             ) if $legacy_logger->is_debug;
917             return;
918             }
919              
920 0         0 my $self = shift;
921             my $config_class_name = shift || die;
922             my $elt_name = shift;
923 0         0 my $info = shift;
924 0 0       0  
    0          
925             foreach my $bad (qw/min max/) {
926 0 0       0 next unless defined $info->{$bad};
927 0         0  
928             $legacy_logger->debug( "translate_id_min_max $elt_name $bad:")
929             if $legacy_logger->is_debug;
930 0         0  
931 0         0 my $good = $bad . '_index';
932             my $warn = "$config_class_name->$elt_name: '$bad' parameter for list or "
933             . "hash element is deprecated. Use '$good'";
934 0         0  
935             $info->{$good} = delete $info->{$bad};
936             }
937 0 0       0 return;
938             }
939              
940             my ( $self, $config_class_name, $elt_name, $type, $info ) = @_;
941 0         0  
942             $legacy_logger->debug(
943             "translate_warped_node_info $elt_name input:\n",
944             Data::Dumper->Dump( [$info], [qw/info/] )
945 318     318 0 459 ) if $legacy_logger->is_debug;
946 318   50     560  
947 318         394 # type may not be defined when translating class snippet used to augment a class
948 318         373 my $elt_type = $info->{type} ;
949             foreach my $parm (qw/follow rules/) {
950 318         457 next unless $info->{$parm};
951 636 100       1197 next if defined $elt_type and $elt_type ne 'warped_node';
952             $self->show_legacy_issue(
953 13 50       30 "$config_class_name->$elt_name: using $parm parameter in "
954             ."warped node is deprecated. $parm must be specified in a warp parameter."
955             );
956 13         63 $info->{warp}{$parm} = delete $info->{$parm};
957 13         36 }
958              
959             $legacy_logger->debug(
960 13         30 "translate_warped_node_info $elt_name output:\n",
961             Data::Dumper->Dump( [$info], [qw/new_info/] )
962 318         409 ) if $legacy_logger->is_debug;
963             return;
964             }
965              
966 1239     1239 0 1919 # internal: translate warp information into 'boolean expr' => { ... }
967             my ( $self, $config_class_name, $elt_name, $type, $warp_info ) = @_;
968 1239 50       2755  
969             $legacy_logger->debug(
970             "translate_warp_info $elt_name input:\n",
971             Data::Dumper->Dump( [$warp_info], [qw/warp_info/] )
972             ) if $legacy_logger->is_debug;
973              
974 1239         6214 my $follow = $self->translate_follow_arg( $config_class_name, $elt_name, $warp_info->{follow} );
975 1239         1680  
976 2478 50       4128 # now, follow is only { w1 => 'warp1', w2 => 'warp2'}
977 0 0 0     0 my @warper_items = values %$follow;
978 0         0  
979             my $multi_follow = @warper_items > 1 ? 1 : 0;
980              
981             my $rules =
982 0         0 $self->translate_rules_arg( $config_class_name, $elt_name, $type, \@warper_items,
983             $warp_info->{rules} );
984              
985             $warp_info->{follow} = $follow;
986 1239 50       1938 $warp_info->{rules} = $rules;
987              
988             $legacy_logger->debug(
989 1239         5028 "translate_warp_info $elt_name output:\n",
990             Data::Dumper->Dump( [$warp_info], [qw/new_warp_info/] )
991             ) if $legacy_logger->is_debug;
992             return;
993             }
994 119     119 0 252  
995             # internal
996 119 50       243 my ( $self, $config_class_name, $elt_name, $warper_items, $raw_rules ) = @_;
997             my @rules;
998              
999             # we have more than one warper_items
1000              
1001 119         714 for ( my $r_idx = 0 ; $r_idx < $#$raw_rules ; $r_idx += 2 ) {
1002             my $key_set = $raw_rules->[$r_idx];
1003             my @keys = ref($key_set) ? @$key_set : ($key_set);
1004 119         331  
1005             # legacy: check the number of keys in the @rules set
1006 119 100       604 if ( @keys != @$warper_items and $key_set !~ /\$\w+/ ) {
1007             Config::Model::Exception::ModelDeclaration->throw( error => "Warp rule error in "
1008             . "'$config_class_name->$elt_name'"
1009             . ": Wrong nb of keys in set '@keys',"
1010 119         361 . " Expected "
1011             . scalar @$warper_items
1012 119         208 . " keys" );
1013 119         225 }
1014              
1015 119 50       272 # legacy:
1016             # if a key of a rule (e.g. f1 or b1) is an array ref, all the
1017             # values passed in the array are considered as valid.
1018             # i.e. [ [ f1a, f1b] , b1 ] => { ... }
1019 119         623 # is equivalent to
1020             # [ f1a, b1 ] => { ... }, [ f1b , b1 ] => { ... }
1021              
1022             # now translate [ [ f1a, f1b] , b1 ] => { ... }
1023             # into "( $f1 eq f1a or $f1 eq f1b ) and $f2 eq b1)" => { ... }
1024 12     12 0 25 my @bool_expr;
1025 12         17 my $b_idx = 0;
1026             foreach my $key (@keys) {
1027             if ( ref $key ) {
1028             my @expr = map { "\$f$b_idx eq '$_'" } @$key;
1029 12         41 push @bool_expr, "(" . join( " or ", @expr ) . ")";
1030 31         46 }
1031 31 100       69 elsif ( $key !~ /\$\w+/ ) {
1032             push @bool_expr, "\$f$b_idx eq '$key'";
1033             }
1034 31 50 66     102 else {
1035 0         0 push @bool_expr, $key;
1036             }
1037             $b_idx++;
1038             }
1039             push @rules, join( ' and ', @bool_expr ), $raw_rules->[ $r_idx + 1 ];
1040             }
1041             return @rules;
1042             }
1043              
1044             my $self = shift;
1045             my $config_class_name = shift;
1046             my $elt_name = shift;
1047             my $raw_follow = shift;
1048              
1049             if ( ref($raw_follow) eq 'HASH' ) {
1050              
1051             # follow is { w1 => 'warp1', w2 => 'warp2'}
1052 31         37 return $raw_follow;
1053 31         33 }
1054 31         44 elsif ( ref($raw_follow) eq 'ARRAY' ) {
1055 67 100       124  
    100          
1056 1         2 # translate legacy follow arguments ['warp1','warp2',...]
  2         6  
1057 1         4 my $follow = {};
1058             my $idx = 0;
1059             foreach ( @$raw_follow ) { $follow->{ 'f' . $idx++ } = $_ } ;
1060 57         85 return $follow;
1061             }
1062             elsif ( defined $raw_follow ) {
1063 9         21  
1064             # follow is a plain string
1065 67         72 return { f1 => $raw_follow };
1066             }
1067 31         108 else {
1068             return {};
1069 12         36 }
1070             }
1071              
1072             my ( $self, $config_class_name, $elt_name, $type, $warper_items, $raw_rules ) = @_;
1073 119     119 0 195  
1074 119         164 my $multi_follow = @$warper_items > 1 ? 1 : 0;
1075 119         159 my $follow = @$warper_items;
1076 119         164  
1077             # $rules is either:
1078 119 100       440 # { f1 => { ... } } ( may be [ f1 => { ... } ] ?? )
    100          
    100          
1079             # [ 'boolean expr' => { ... } ]
1080             # legacy:
1081 21         47 # [ f1, b1 ] => {..} ,[ f1,b2 ] => {...}, [f2,b1] => {...} ...
1082             # foo => {...} , bar => {...}
1083             my @rules;
1084             if ( ref($raw_rules) eq 'HASH' ) {
1085              
1086 5         12 # transform the hash { foo => { ...} }
1087 5         6 # into array ref [ '$f1 eq foo' => { ... } ]
1088 5         12 my $h = $raw_rules;
  12         31  
1089 5         9 @rules = $follow ? map { ( "\$f1 eq '$_'", $h->{$_} ) } keys %$h : keys %$h;
1090             }
1091             elsif ( ref($raw_rules) eq 'ARRAY' ) {
1092             if ($multi_follow) {
1093             push @rules,
1094 90         251 $self->translate_multi_follow_legacy_rules( $config_class_name, $elt_name,
1095             $warper_items, $raw_rules );
1096             }
1097 3         7 else {
1098             # now translate [ f1a, f1b] => { ... }
1099             # into "$f1 eq f1a or $f1 eq f1b " => { ... }
1100             my @raw_rules = @{$raw_rules};
1101             for ( my $r_idx = 0 ; $r_idx < $#raw_rules ; $r_idx += 2 ) {
1102 119     119 0 273 my $key_set = $raw_rules[$r_idx];
1103             my @keys = ref($key_set) ? @$key_set : ($key_set);
1104 119 100       245 my @bool_expr = $follow ? map { /\$/ ? $_ : "\$f1 eq '$_'" } @keys : @keys;
1105 119         165 push @rules, join( ' or ', @bool_expr ), $raw_rules[ $r_idx + 1 ];
1106             }
1107             }
1108             }
1109             elsif ( defined $raw_rules ) {
1110             Config::Model::Exception::ModelDeclaration->throw(
1111             error => "Warp rule error in element "
1112             . "'$config_class_name->$elt_name': "
1113 119         154 . "rules must be a hash ref. Got '$raw_rules'" );
1114 119 100       352 }
    50          
    0          
1115              
1116             for ( my $idx = 1 ; $idx < @rules ; $idx += 2 ) {
1117             next unless ( ref $rules[$idx] eq 'HASH' ); # other cases are illegal and trapped later
1118 35         71 $self->handle_experience_permission( $config_class_name, $rules[$idx] );
1119 35 50       130 next unless defined $type and $type eq 'leaf';
  47         188  
1120             $self->translate_legacy_builtin( $config_class_name, $rules[$idx], $rules[$idx] );
1121             }
1122 84 100       176  
1123 12         39 return \@rules;
1124             }
1125              
1126             my ( $self, $config_class_name, $model, $normalized_model ) = @_;
1127              
1128             my $raw_builtin_default = delete $normalized_model->{built_in};
1129             return unless defined $raw_builtin_default;
1130 72         101  
  72         405  
1131 72         231 $legacy_logger->debug(
1132 152         245 Data::Dumper->Dump( [$normalized_model], ['builtin to translate'] )
1133 152 100       301 ) if $legacy_logger->is_debug;
1134 152 100       296  
  151 100       572  
1135 152         610 $self->show_legacy_issue([ "$config_class_name: parameter 'built_in' is deprecated "
1136             . "in favor of 'upstream_default'" ]);
1137              
1138             $model->{upstream_default} = $raw_builtin_default;
1139              
1140 0         0 $legacy_logger->debug( Data::Dumper->Dump( [$model], ['translated_builtin'] ))
1141             if $legacy_logger->is_debug;
1142             return;
1143             }
1144              
1145             my ( $self, $config_class_name, $model, $normalized_model ) = @_;
1146 119         322  
1147 230 100       483 my $raw_builtin_default = delete $normalized_model->{built_in_list};
1148 229         500 return unless defined $raw_builtin_default;
1149 229 100 100     777  
1150 89         203 $legacy_logger->debug(
1151             Data::Dumper->Dump( [$normalized_model], ['built_in_list to translate'] )
1152             ) if $legacy_logger->is_debug;
1153 119         257  
1154             $self->show_legacy_issue([ "$config_class_name: parameter 'built_in_list' is deprecated "
1155             . "in favor of 'upstream_default_list'" ]);
1156              
1157 770     770 0 1234 $model->{upstream_default_list} = $raw_builtin_default;
1158              
1159 770         1029 $legacy_logger->debug( Data::Dumper->Dump( [$model], ['translated_built_in_list'] ))
1160 770 50       1447 if $legacy_logger->is_debug;
1161             return;
1162 0 0       0 }
1163              
1164             my $self = shift;
1165             my $class_name = shift || croak "include_class: undef includer";
1166 0         0 my $target_model = shift || die "include_class: undefined target_model";
1167              
1168             my $include_class = delete $target_model->{include};
1169 0         0  
1170             return () unless defined $include_class;
1171 0 0       0  
1172             my $include_after = delete $target_model->{include_after};
1173 0         0  
1174             my @includes = ref $include_class ? @$include_class : ($include_class);
1175              
1176             # use reverse because included classes are *inserted* in front
1177 63     63 0 169 # of the list (or inserted after $include_after
1178             foreach my $inc ( reverse @includes ) {
1179 63         126 $self->include_one_class( $class_name, $target_model, $inc, $include_after );
1180 63 50       162 }
1181             return;
1182 0 0       0 }
1183              
1184             my $self = shift;
1185             my $class_name = shift || croak "include_class: undef includer";
1186 0         0 my $target_model = shift || croak "include_class: undefined target_model";
1187             my $include_class = shift || croak "include_class: undef include_class param";
1188             my $include_after = shift;
1189 0         0  
1190             get_logger('Model')->debug("class $class_name includes $include_class");
1191 0 0       0  
1192             if ( defined $include_class
1193 0         0 and defined $self->{included_class}{$class_name}{$include_class} ) {
1194             Config::Model::Exception::ModelDeclaration->throw(
1195             error => "Recursion error ? $include_class has "
1196             . "already been included by $class_name." );
1197 245     245 0 437 }
1198 245   33     624 $self->{included_class}{$class_name}{$include_class} = 1;
1199 245   50     609  
1200             # takes care of recursive include, because get_model will perform
1201 245         544 # includes (and normalization). Is already a dclone
1202             my $included_model = $self->get_model_clone($include_class);
1203 245 100       736  
1204             # now include element in element_list (special treatment because order is
1205 64         139 # important)
1206             my $target_list = $target_model->{element_list};
1207 64 100       228 my $included_list = $included_model->{element_list};
1208             my $splice_idx = 0;
1209             if ( defined $include_after and defined $included_model->{element} ) {
1210             my $idx = 0;
1211 64         145 my %elt_idx = map { ( $_, $idx++ ); } @$target_list;
1212 65         288  
1213             if ( not defined $elt_idx{$include_after} ) {
1214 63         136 my $msg =
1215             "Unknown element for 'include_after': "
1216             . "$include_after, expected "
1217             . join( ' ', sort keys %elt_idx );
1218 65     65 0 310 Config::Model::Exception::ModelDeclaration->throw( error => $msg );
1219 65   33     160 }
1220 65   33     154  
1221 65   33     140 # + 1 because we splice *after* $include_after
1222 65         108 $splice_idx = $elt_idx{$include_after} + 1;
1223             }
1224 65         361  
1225             splice( @$target_list, $splice_idx, 0, @$included_list );
1226 65 50 33     3069 get_logger('Model')->debug("class $class_name new elt list: @$target_list");
1227              
1228 0         0 # now actually include all elements
1229             my $target_element = $target_model->{element} ||= {};
1230             foreach my $included_elt (@$included_list) {
1231             if ( not defined $target_element->{$included_elt} ) {
1232 65         197 get_logger('Model')->debug("class $class_name includes elt $included_elt");
1233             $target_element->{$included_elt} = $included_model->{element}{$included_elt};
1234             }
1235             else {
1236 65         222 Config::Model::Exception::ModelDeclaration->throw(
1237             error => "Cannot clobber element '$included_elt' in $class_name"
1238             . " (included from $include_class)" );
1239             }
1240 65         2712 }
1241 65         123 get_logger('Model')->debug("class $class_name include $include_class done");
1242 65         117 return;
1243 65 100 66     274 }
1244 24         46  
1245 24         68 foreach my $ext (qw/yml yaml pl/) {
  57         175  
1246             my $sub_path = $model_name =~ s!::!/!rg;
1247 24 50       96 my $path_load_file = $model_path->child($sub_path . '.' . $ext);
1248 0         0 return $path_load_file if $path_load_file->exists;
1249             }
1250             return;
1251             }
1252 0         0  
1253             my ($self, $model_name, $load_file) = @_;
1254              
1255             my $path_load_file ;
1256 24         59  
1257             if ($load_file and $load_file =~ m!^/! ) {
1258             # load_file is absolute, do not search in @INC
1259 65         197 $path_load_file = $load_file;
1260 65         208 } elsif ($self->model_dir and $self->model_dir =~ m!^/!) {
1261             # model_dir is absolute, do not search in @INC
1262             my $model_path = path($self->model_dir);
1263 65   100     2348 $path_load_file = find_model_file_in_dir ($model_name, $model_path);
1264 65         164 Config::Model::Exception::ModelDeclaration->throw(
1265 111 100       245 error => "Cannot find $model_name file in $model_path"
1266 110         198 ) unless $path_load_file;
1267 110         2912 }
1268             else {
1269             foreach my $inc_str (@INC) {
1270 1         24 my $inc_path = path($inc_str);
1271             if ($load_file) {
1272             $path_load_file = $inc_path->child($load_file);
1273             }
1274             else {
1275 64         151 my $sub_path = $model_name =~ s!::!/!rg;
1276 64         1758 my $model_path = $inc_path->child($self->model_dir);
1277             foreach my $ext (qw/yml yaml pl/) {
1278             $path_load_file = $model_path->child($sub_path . '.' . $ext);
1279 0     0 0 0 last if $path_load_file->exists;
  0         0  
  0         0  
  0         0  
1280 0         0 }
1281 0         0 }
1282 0         0 last if $path_load_file->exists;
1283 0 0       0 }
1284             }
1285 0         0  
1286             Config::Model::Exception::ModelDeclaration->throw(
1287             error => "Cannot find $model_name file in \@INC"
1288             ) unless $path_load_file;
1289 50     50 0 162  
1290             $loader_logger->debug("model $model_name from file $path_load_file");
1291 50         93  
1292             return $path_load_file;
1293 50 100 100     714 }
    50 33        
1294              
1295 1         9 my ($self, @model_names) = @_;
1296              
1297             # look for additional model information
1298 0         0 my %model_graft_by_name;
1299 0         0 my %done; # avoid loading twice the same snippet (where system version may clobber dev version)
1300 0 0       0  
1301             foreach my $inc_str (@INC) {
1302             foreach my $name ( @model_names ) {
1303             my $snippet_path = $name;
1304             $snippet_path =~ s/::/\//g;
1305 49         180 my $snippet_dir = path($inc_str)->absolute->child($self->model_dir)->child($snippet_path . '.d');
1306 75         560 $loader_logger->trace("looking for snippet in $snippet_dir");
1307 75 100       2299 if ( $snippet_dir->is_dir ) {
1308 19         74 my $iter = $snippet_dir->iterator({ recurse => 1 });
1309              
1310             while ( my $snippet_file = $iter->() ) {
1311 56         180 next unless $snippet_file =~ /\.pl$/;
1312 56         252  
1313 56         1561 # $snippet_file (Path::Tiny object) was
1314 168         2465 # constructed from @INC content (i.e. $inc_str)
1315 168 100       4733 # and contains an absolute path. Since
1316             # _load_model_in_hash uses 'do' (which may search
1317             # in @INC), the file path passed to
1318 75 100       1843 # _load_model_in_hash must be either absolute or
1319             # relative to $inc_str
1320             my $snippet_file_rel = $snippet_file->relative($inc_str);
1321              
1322 50 50       1179 my $done_key = $name . ':' . $snippet_file_rel;
1323             next if $done{$done_key};
1324             $loader_logger->info("Found snippet $snippet_file in $inc_str dir");
1325             my $snippet_model = $self->_load_model_file($snippet_file);
1326 50         303  
1327             $self->_merge_model_in_hash( \%model_graft_by_name, $snippet_model, $snippet_file_rel);
1328 50         625 $done{$done_key} = 1;
1329             }
1330             }
1331             }
1332 49     49 0 178 }
1333             return %model_graft_by_name;
1334             }
1335 49         114  
1336             # load a model from file. See comments around raw_models attribute for explanations
1337             my $self = shift;
1338 49         140 my $model_name = shift; # model name like Foo::Bar
1339 528         7567 my $load_file = shift; # model file (override model name), used for tests
1340 3003         34167  
1341 3003         5120 $loader_logger->debug("called on model $model_name");
1342 3003         6382 my $path_load_file = $self->find_model_file_in_inc($model_name, $load_file);
1343 3003         277757  
1344 3003 100       27341 my %models_by_name;
1345 1         23  
1346             # Searches $load_file in @INC and returns an array containing the
1347 1         27 # names of the loaded classes
1348 1 50       148 my $model = $self->_load_model_file($path_load_file->absolute);
1349             my @loaded_classes = $self->_merge_model_in_hash( \%models_by_name, $model, $path_load_file );
1350              
1351             $self->store_raw_model( $model_name, dclone( \%models_by_name ) );
1352              
1353             foreach my $name ( keys %models_by_name ) {
1354             my $data = $self->normalize_class_parameters( $name, $models_by_name{$name} );
1355             $loader_logger->debug("Store normalized model $name");
1356             $self->store_normalized_model( $name, $data );
1357 1         10 }
1358              
1359 1         269 my %model_graft_by_name = $self->load_model_plugins(sort keys %models_by_name);
1360 1 50       6  
1361 1         3 # store snippet. May be used later
1362 1         13 foreach my $name (keys %model_graft_by_name) {
1363             # store snippet for later usage
1364 1         4 $loader_logger->trace("storing snippet for model $name");
1365 1         6 $self->add_snippet($model_graft_by_name{$name});
1366             }
1367              
1368             # check if a snippet is available for this class
1369             foreach my $snippet ( $self->all_snippets ) {
1370 49         889 my $class_to_merge = $snippet->{name};
1371             next unless $models_by_name{$class_to_merge};
1372             $self->augment_config_class_really( $class_to_merge, $snippet );
1373             }
1374              
1375 50     50 1 89551 # return the list of classes found in $load_file. Respecting the order of the class
1376 50         100 # declaration is important for Config::Model::Itself so the class are written back
1377 50         94 # in the same order.
1378             return @loaded_classes;
1379 50         459 }
1380 50         612  
1381             # New subroutine "_load_model_in_hash" extracted - Fri Apr 12 17:29:56 2013.
1382 50         99 #
1383             my ( $self, $hash_ref, $model, $load_file ) = @_;
1384              
1385             my @names;
1386 50         221 foreach my $config_class_info (@$model) {
1387 49         297 my %data =
1388             ref $config_class_info eq 'HASH' ? %$config_class_info
1389 49         7449 : ref $config_class_info eq 'ARRAY' ? @$config_class_info
1390             : croak "load $load_file: config_class_info is not a ref";
1391 49         2532 my $config_class_name = $data{name}
1392 274         8198 or croak "load: missing config class name in $load_file";
1393 274         1036  
1394 274         2301 # check config class parameters and fill %model
1395             $hash_ref->{$config_class_name} = \%data;
1396             push @names, $config_class_name;
1397 49         2053 }
1398              
1399             return @names;
1400 49         205 }
1401              
1402 1         6 my ( $self, $load_file ) = @_;
1403 1         10  
1404             $loader_logger->info("load model $load_file");
1405              
1406             my $err_msg = '';
1407 49         338 # do searches @INC if the file path is not absolute
1408 2         18 my $model = do $load_file;
1409 2 100       7  
1410 1         4 unless ($model) {
1411             if ($@) { $err_msg = "couldn't parse $load_file: $@"; }
1412             elsif ( not defined $model ) { $err_msg = "couldn't do $load_file: $!" }
1413             else { $err_msg = "couldn't run $load_file"; }
1414             }
1415             elsif ( ref($model) ne 'ARRAY' ) {
1416 49         2026 $model = [$model];
1417             }
1418              
1419             Config::Model::Exception::ModelDeclaration->throw( message => "load error: $err_msg" )
1420             if $err_msg;
1421              
1422 50     50   171 return $model;
1423             }
1424 50         94  
1425 50         136 my ( $self, %augment_data ) = @_;
1426 275 50       1041  
    100          
1427             # %args must contain existing class name to augment
1428              
1429             # plus other data to merge to raw model
1430             my $config_class_name = delete $augment_data{name}
1431 275 50       590 || croak "augment_config_class: missing class name";
1432              
1433             $self->augment_config_class_really( $config_class_name, \%augment_data );
1434 275         516 return;
1435 275         526 }
1436              
1437             my ( $self, $config_class_name, $augment_data ) = @_;
1438 50         235  
1439             my $orig_model = $self->normalized_model($config_class_name);
1440             croak "unknown class to augment: $config_class_name" unless defined $orig_model;
1441              
1442 51     51   3512 my $model_addendum = $self->normalize_class_parameters( $config_class_name, dclone($augment_data) );
1443              
1444 51         188 my $merge = Hash::Merge->new('RIGHT_PRECEDENT');
1445             my $new_model = $merge->merge( $orig_model, $model_addendum );
1446 51         606  
1447             # remove duplicates in element_list and accept_list while keeping order
1448 51         139 foreach my $list_name (qw/element_list accept_list/) {
1449             my %seen;
1450 51 100 66     27283 my @newlist;
1451 1 50       6 foreach my $elt ( @{ $new_model->{$list_name} } ) {
  0 50       0  
1452 1         4 push @newlist, $elt unless $seen{$elt};
1453 0         0 $seen{$elt} = 1;
1454             }
1455              
1456             $new_model->{$list_name} = \@newlist;
1457             }
1458              
1459 51 100       236 $self->store_normalized_model( $config_class_name => $new_model );
1460             return;
1461             }
1462 50         140  
1463             my $self = shift;
1464             my $config_class_name = shift
1465             || die "Model::get_model: missing config class name argument";
1466 5     5 1 2133  
1467             $self->load($config_class_name)
1468             unless $self->normalized_model_exists($config_class_name);
1469              
1470             if ( not $self->model_defined($config_class_name) ) {
1471             $loader_logger->debug("creating model $config_class_name");
1472 5   33     21  
1473             my $model = $self->merge_included_class($config_class_name);
1474 5         24 $self->_store_model( $config_class_name, $model );
1475 5         16 }
1476              
1477             return $self->_get_model($config_class_name)
1478             || croak "get_model error: unknown config class name: $config_class_name";
1479 6     6 0 16  
1480             }
1481 6         25  
1482 6 50       93 my ($self,$model) = @_;
1483             carp "get_model is deprecated in favor of get_model_clone";
1484 6         310 return $self->get_model_clone($model);
1485             }
1486 6         57  
1487 6         567 my ($self,$model) = @_;
1488             return dclone($self->model($model));
1489             }
1490 6         3240  
1491 12         22 # internal
1492             my ( $self, $top_class_name, $done ) = @_;
1493 12         15  
  12         27  
1494 83 100       148 $done //= {};
1495 83         119 if ( not defined $self->normalized_model($top_class_name) ) {
1496             eval { $self->model($top_class_name); };
1497             if ($@) {
1498 12         35 my $e = $@;
1499             if ($e->isa('Config::Model::Exception::ModelDeclaration')) {
1500             Config::Model::Exception::Fatal->throw(
1501 6         28 message => "Unknown configuration class : $top_class_name ($@)"
1502 6         499 );
1503             }
1504             else {
1505             $e->rethrow;
1506 3562     3562 1 5041 }
1507 3562   50     6789 }
1508             }
1509              
1510 3562 100       9270 my @classes = ($top_class_name);
1511             my %result;
1512              
1513 3561 100       35262 while (@classes) {
1514 245         3140 my $class_name = shift @classes;
1515             next if $done->{$class_name} ;
1516 245         2389  
1517 244         892 my $c_model = $self->model($class_name)
1518             || croak "get_model_doc model error : unknown config class name: $class_name";
1519              
1520 3560   33     38650 my $full_name = "Config::Model::models::$class_name";
1521              
1522             my %see_also;
1523              
1524             my @pod = (
1525              
1526 0     0 0 0 # Pod::Weaver compatibility
1527 0         0 "# PODNAME: $full_name",
1528 0         0 "# ABSTRACT: Configuration class " . $class_name, '',
1529              
1530             # assume utf8 for all docs
1531             "=encoding utf8", '',
1532 939     939 1 3635  
1533 939         2635 # plain old pod compatibility
1534             "=head1 NAME", '',
1535             "$full_name - Configuration class " . $class_name, '',
1536              
1537             "=head1 DESCRIPTION", '',
1538 3     3 0 13 "Configuration classes used by L<Config::Model>", ''
1539             );
1540 3   100     12  
1541 3 100       13 my %legalese;
1542 2         45  
  2         13  
1543 2 100       79 my $i = 0;
1544 1         2  
1545 1 50       16 my $class_desc = $c_model->{class_description};
1546 1         8 push @pod, $class_desc, '' if defined $class_desc;
1547              
1548             my @elt = ( "=head1 Elements", '' );
1549             foreach my $elt_name ( @{ $c_model->{element_list} } ) {
1550             my $elt_info = $c_model->{element}{$elt_name};
1551 0         0 my $summary = $elt_info->{summary} || '';
1552             $summary &&= " - $summary";
1553             push @elt, "=head2 $elt_name$summary", '';
1554             push @elt, $self->get_element_description($elt_info), '';
1555              
1556 2         19 foreach ( $elt_info, $elt_info->{cargo} ) {
1557 2         4 if ( my $ccn = $_->{config_class_name} ) {
1558             push @classes, $ccn;
1559 2         7 $see_also{$ccn} = 1;
1560 18         24 }
1561 18 100       36 if ( my $migr = $_->{migrate_from} ) {
1562             push @elt, $self->get_migrate_doc( $elt_name, 'is migrated with', $migr );
1563 10   33     23 }
1564             if ( my $migr = $_->{migrate_values_from} ) {
1565             push @elt, "Note: $elt_name values are migrated from '$migr'", '';
1566 10         126 }
1567             if ( my $comp = $_->{compute} ) {
1568 10         12 push @elt, $self->get_migrate_doc( $elt_name, 'is computed with', $comp );
1569             }
1570 10         43 }
1571             }
1572              
1573             foreach my $what (qw/author copyright license/) {
1574             my $item = $c_model->{$what};
1575             push @{ $legalese{$what} }, $item if $item;
1576             }
1577              
1578             my @end;
1579             foreach my $what (qw/author copyright license/) {
1580             next unless @{ $legalese{$what} || [] };
1581             push @end, "=head1 " . uc($what), '', '=over', '',
1582             ( map { ( "=item $_", '' ); } map { ref $_ ? @$_ : $_ } @{ $legalese{$what} } ),
1583             '', '=back', '';
1584             }
1585              
1586             my @see_also = (
1587 10         13 "=head1 SEE ALSO",
1588             '',
1589 10         15 "=over",
1590             '',
1591 10         15 "=item *",
1592 10 100       21 '',
1593             "L<cme>",
1594 10         17 '',
1595 10         38 ( map { ( "=item *", '', "L<Config::Model::models::$_>", '' ); } sort keys %see_also ),
  10         21  
1596 75         100 "=back",
1597 75   50     159 ''
1598 75   33     105 );
1599 75         135  
1600 75         120 $result{$full_name} = join( "\n", @pod, @elt, @see_also, @end, '=cut', '' ) . "\n";
1601             $done->{$class_name} = 1;
1602 75         114 }
1603 150 100       219 return \%result;
1604 16         20 }
1605 16         20  
1606             #
1607 150 50       201 # New subroutine "get_migrate_doc" extracted - Tue Jun 5 13:31:20 2012.
1608 0         0 #
1609             my ( $self, $elt_name, $desc, $migr ) = @_;
1610 150 50       190  
1611 0         0 my $mv = $migr->{variables};
1612             my $mform = $migr->{formula};
1613 150 50       257  
1614 0         0 if ( $mform =~ /\n/) { $mform =~ s/^/ /mg; $mform = "\n\n$mform\n\n"; }
1615             else { $mform = "'C<$mform>' " }
1616              
1617             my $mdoc = "Note: $elt_name $desc ${mform}and with: \n\n=over\n\n=item *\n\n"
1618             . join( "\n\n=item *\n\n", map { qq!C<\$$_> => C<$mv->{$_}>! } sort keys %$mv );
1619 10         20 if ( my $rep = $migr->{replace} ) {
1620 30         38 $mdoc .= "\n\n=item *\n\n"
1621 30 100       46 . join( "\n\n=item *\n\n", map { qq!C<\$replace{$_}> => C<$rep->{$_}>! } sort keys %$rep );
  6         17  
1622             }
1623             $mdoc .= "\n\n=back\n\n";
1624 10         13  
1625 10         15 return ( $mdoc, '' );
1626 30 100       35 }
  30 100       83  
1627              
1628 6 100       16 my ( $self, $elt_info ) = @_;
  6         23  
  6         16  
  6         12  
1629              
1630             my $type = $elt_info->{type};
1631             my $cargo = $elt_info->{cargo};
1632             my $vt = $elt_info->{value_type};
1633              
1634             my $of = '';
1635             my $cargo_type = $cargo->{type};
1636             my $cargo_vt = $cargo->{value_type};
1637             $of = " of " . ( $cargo_vt or $cargo_type ) if defined $cargo_type;
1638              
1639             my $ccn = $elt_info->{config_class_name} || $cargo->{config_class_name};
1640             $of .= " of class L<$ccn|Config::Model::models::$ccn> " if $ccn;
1641 10         39  
  10         38  
1642             my $desc = $elt_info->{description} || '';
1643             if ($desc) {
1644             $desc .= '.' if $desc =~ /\w$/;
1645             $desc .= ' ' unless $desc =~ /\s$/;
1646 10         83 }
1647 10         56  
1648             if ( my $status = $elt_info->{status} ) {
1649 2         9 $desc .= 'B<' . ucfirst($status) . '> ';
1650             }
1651              
1652             my $info = $elt_info->{mandatory} ? 'Mandatory. ' : 'Optional. ';
1653              
1654             $info .= "Type " . ( $vt || $type ) . $of . '. ';
1655              
1656 0     0 0 0 foreach my $name (qw/choice/) {
1657             my $item = $elt_info->{$name};
1658 0         0 next unless defined $item;
1659 0         0 $info .= "$name: '" . join( "', '", @$item ) . "'. ";
1660             }
1661 0 0       0  
  0         0  
  0         0  
1662 0         0 my @default_info = ();
1663             # assemble in over item for string value_type
1664             foreach my $name (qw/default upstream_default/) {
1665 0         0 my $item = $elt_info->{$name};
  0         0  
1666 0 0       0 next unless defined $item;
1667             push @default_info, [$name, $item] ;
1668 0         0 }
  0         0  
1669              
1670 0         0 my $elt_help = $self->get_element_value_help($elt_info);
1671              
1672 0         0 # breaks pod if $info is multiline
1673             my $ret = $desc . "I< $info > ";
1674              
1675             if (@default_info) {
1676 75     75 0 102 $ret .= "\n\n=over 4\n\n";
1677             for ( @default_info) { $ret .= "=item $_->[0] value :\n\n$_->[1]\n\n"; }
1678 75         89 $ret .= "=back\n\n";
1679 75         85 }
1680 75         86  
1681             $ret.= $elt_help;
1682 75         78 return $ret;
1683 75         89 }
1684 75         77  
1685 75 100 66     125 my ( $self, $elt_info ) = @_;
1686              
1687 75   100     144 my $help = $elt_info->{help};
1688 75 100       114 return '' unless defined $help;
1689              
1690 75   100     142 my $help_text = "\n\nHere are some explanations on the possible values:\n\n=over\n\n";
1691 75 100       103 foreach my $v ( sort keys %$help ) {
1692 6 50       28 $help_text .= "=item '$v'\n\n$help->{$v}\n\n";
1693 6 50       19 }
1694              
1695             return $help_text . "=back\n\n";
1696 75 50       116 }
1697 0         0  
1698             my ( $self, $top_class_name, $dir_str, $done ) = @_;
1699              
1700 75 100       108 $done //= {} ;
1701             my $res = $self->get_model_doc($top_class_name, $done);
1702 75   66     136  
1703             if ( defined $dir_str and $dir_str ) {
1704 75         94 foreach my $class_name ( sort keys %$res ) {
1705 75         88 my $dir = path($dir_str);
1706 75 100       127 $dir->mkpath() unless $dir->exists;
1707 12         32 my $file_path = $class_name;
1708             $file_path =~ s!::!/!g;
1709             my $pl_file = $dir->child("$file_path.pl");
1710 75         84 $pl_file->parent->mkpath unless $pl_file->parent->exists;
1711             my $pod_file = $dir->child("$file_path.pod");
1712 75         87  
1713 150         172 my $old = '';
1714 150 100       207 if ($pod_file->exists ) {
1715 11         26 $old = $pod_file->slurp_utf8;
1716             }
1717             if ( $old ne $res->{$class_name} ) {
1718 75         119 $pod_file->spew_utf8( $res->{$class_name} );
1719             say "Wrote documentation in $pod_file";
1720             }
1721 75         130 }
1722             }
1723 75 100       113 else {
1724 11         16 foreach my $class_name ( sort keys %$res ) {
1725 11         18 print "########## $class_name ############ \n\n";
  11         22  
1726 11         17 print $res->{$class_name};
1727             }
1728             }
1729 75         113 return;
1730 75         170 }
1731              
1732             my $self = shift;
1733             my $config_class_name = shift
1734 75     75 0 90 || die "Model::get_element_model: missing config class name argument";
1735             my $element_name = shift
1736 75         79 || die "Model::get_element_model: missing element name argument";
1737 75 100       138  
1738             my $model = $self->model($config_class_name);
1739 2         5  
1740 2         11 my $element_m = $model->{element}{$element_name}
1741 6         15 || croak "get_element_model error: unknown element name: $element_name";
1742              
1743             return dclone($element_m);
1744 2         8 }
1745              
1746             # returns a hash ref containing the raw model, i.e. before expansion of
1747             # multiple keys (i.e. [qw/a b c/] => ... )
1748 2     2 1 19252 # internal. For now ...
1749             my $self = shift;
1750 2   50     15 my $config_class_name = shift;
1751 2         9  
1752             $self->load($config_class_name)
1753 1 50 33     7 unless defined $self->normalized_model($config_class_name);
1754 1         6  
1755 5         155 my $normalized_model = $self->normalized_model($config_class_name)
1756 5 50       75 || croak "get_normalized_model error: unknown config class name: $config_class_name";
1757 5         84  
1758 5         27 return dclone($normalized_model);
1759 5         17 }
1760 5 100       173  
1761 5         651 my $class = $args{class}
1762             || croak "get_element_name: missing 'class' parameter";
1763 5         148  
1764 5 50       11 if (delete $args{for}) {
1765 0         0 carp "get_element_name: 'for' parameter is deprecated";
1766             }
1767 5 50       107  
1768 5         19 my $model = $self->model($class);
1769 5         2876 my @result;
1770              
1771             # this is a bit convoluted, but the order of the returned element
1772             # must respect the order of the elements declared in the model by
1773             # the user
1774 0         0 foreach my $elt ( @{ $model->{element_list} } ) {
1775 0         0 my $elt_data = $model->{element}{$elt};
1776 0         0 my $l = $elt_data->{level} || get_default_property('level');
1777             push @result, $elt if $l ne 'hidden' ;
1778             }
1779 1         41  
1780             return wantarray ? @result : join( ' ', @result );
1781             }
1782              
1783 3     3 1 115 my $elt = $args{element}
1784 3   50     12 || croak "get_element_property: missing 'element' parameter";
1785             my $prop = $args{property}
1786 3   50     9 || croak "get_element_property: missing 'property' parameter";
1787             my $class = $args{class}
1788             || croak "get_element_property:: missing 'class' parameter";
1789 3         10  
1790             my $model = $self->model($class);
1791 3   33     45  
1792             # must take into account 'accept' model parameter
1793             if ( not defined $model->{element}{$elt} ) {
1794 3         153 $logger->debug("test accept for class $class elt $elt prop $prop");
1795             foreach my $acc_re ( @{ $model->{accept_list} } ) {
1796             return $model->{accept}{$acc_re}{$prop} || get_default_property($prop)
1797             if $elt =~ /^$acc_re$/;
1798             }
1799             }
1800              
1801 0     0 0 0 return $self->model($class)->{element}{$elt}{$prop}
1802 0         0 || get_default_property($prop);
1803             }
1804 0 0       0  
1805             my $self = shift;
1806             my $pad = shift || '';
1807 0   0     0  
1808             my $res = '';
1809             foreach my $class_name ( $self->normalized_model_names ) {
1810 0         0 $res .= $self->list_one_class_element($class_name);
1811             }
1812             return $res;
1813 104     104 1 127 }
  104         135  
  104         163  
  104         107  
1814              
1815 104   33     208 my $self = shift;
1816             my $class_name = shift;
1817 104 50       172 my $pad = shift || '';
1818 0         0  
1819             my $res = $pad . "Class: $class_name\n";
1820             my $c_model = $self->normalized_model($class_name);
1821 104         186 my $elts = $c_model->{element_list}; # array ref
1822 104         1072  
1823             return $res unless defined $elts and @$elts;
1824              
1825             foreach my $elt_name (@$elts) {
1826             my $type = $c_model->{element}{$elt_name}{type};
1827 104         117 $res .= $pad . " - $elt_name ($type)\n";
  104         173  
1828 542         658 }
1829 542   66     1085 return $res;
1830 542 100       1099 }
1831              
1832             __PACKAGE__->meta->make_immutable;
1833 104 50       421  
1834             1;
1835              
1836 896     896 1 1595 # ABSTRACT: a framework to validate, migrate and edit configuration files
  896         1146  
  896         2041  
  896         1163  
1837              
1838 896   33     2167  
1839             =pod
1840 896   33     1957  
1841             =encoding UTF-8
1842 896   33     1889  
1843             =head1 NAME
1844 896         2263  
1845             Config::Model - a framework to validate, migrate and edit configuration files
1846              
1847 896 100       11727 =head1 VERSION
1848 52         187  
1849 52         397 version 2.151
  52         82  
1850 110 100 66     952  
1851             =head1 SYNOPSIS
1852              
1853             =head2 Perl program to use an existing model
1854              
1855 844   66     1768 use Config::Model qw(cme);
1856             # load, modify and save popcon configuration file
1857             cme('popcon')->modify("PARTICIPATE=yes");
1858              
1859             =head2 Command line to use an existing model
1860 1     1 1 1193  
1861 1   50     7 # with App::Cme
1862             cme modify popcon 'PARTICIPATE=yes'
1863 1         3  
1864 1         8 =head2 Perl program with a custom model
1865 7         30  
1866             use Config::Model;
1867 1         5  
1868             # create new Model object
1869             my $model = Config::Model->new() ; # Config::Model object
1870              
1871 7     7 0 10 # create config model. A more complex model should be stored in a
1872 7         10 # file in lib/Config/Model/models. Then, run cme as explained below
1873 7   50     17 $model ->create_config_class (
1874             name => "MiniModel",
1875 7         13 element => [ [qw/foo bar baz/ ] => { type => 'leaf', value_type => 'uniline' }, ],
1876 7         16 rw_config => { backend => 'IniFile', auto_create => 1,
1877 7         85 config_dir => '.', file => 'mini.ini',
1878             }
1879 7 100 66     25 ) ;
1880              
1881 6         9 # create instance (Config::Model::Instance object)
1882 36         83 my $instance = $model->instance (root_class_name => 'MiniModel');
1883 36         67  
1884             # get configuration tree root
1885 6         42 my $cfg_root = $instance -> config_root ; # C::M:Node object
1886              
1887             # load some dummy data
1888             $cfg_root -> load("bar=BARV foo=FOOV baz=BAZV") ;
1889              
1890             # write new ini file
1891             $instance -> write_back;
1892              
1893             # now look for new mini.ini file un current directory
1894              
1895             =head2 Create a new model file and use it
1896              
1897             $ mkdir -p lib/Config/Model/models/
1898             $ echo "[ { name => 'MiniModel', \
1899             element => [ [qw/foo bar baz/ ] => { type => 'leaf', value_type => 'uniline' }, ], \
1900             rw_config => { backend => 'IniFile', auto_create => 1, \
1901             config_dir => '.', file => 'mini.ini', \
1902             } \
1903             } \
1904             ] ; " > lib/Config/Model/models/MiniModel.pl
1905             # require App::Cme
1906             $ cme modify -try MiniModel -dev bar=BARV foo=FOOV baz=BAZV
1907             $ cat mini.ini
1908              
1909             Note that model creation is easier running C<cme meta edit> with
1910             L<App::Cme> and L<Config::Model::Itself>.
1911              
1912             =head1 DESCRIPTION
1913              
1914             Config::Model enables a project developer to provide an interactive
1915             configuration editor (graphical, curses based or plain terminal) to
1916             users.
1917              
1918             To provide these tools, Config::Model needs:
1919              
1920             =over
1921              
1922             =item *
1923              
1924             A description of the structure and constraints of the project's configuration
1925             (fear not, a GUI is available with L<App::Cme>)
1926              
1927             =item *
1928              
1929             A module to read and write configuration data (aka a backend class).
1930              
1931             =back
1932              
1933             With the elements above, Config::Model generates interactive
1934             configuration editors (with integrated help and data validation).
1935             These editors can be graphical (with L<Config::Model::TkUI>), curses
1936             based (with L<Config::Model::CursesUI>) or based on ReadLine.
1937              
1938             Smaller models targeted for configuration upgrades can also be created:
1939              
1940             =over
1941              
1942             =item *
1943              
1944             only upgrade and migration specifications are required
1945              
1946             =item *
1947              
1948             unknown parameters can be accepted
1949              
1950             =back
1951              
1952             A command line is provided to perform configuration upgrade with a
1953             single command.
1954              
1955             =head2 How does this work ?
1956              
1957             Using this project, a typical configuration editor/validator/upgrader
1958             is made of 3 parts :
1959              
1960             GUI <--------> |---------------|
1961             CursesUI <---> | |---------| |
1962             | | Model | |
1963             ShellUI <----> | |---------| |<-----read-backend------- |-------------|
1964             | |----write-backend-------> | config file |
1965             FuseUI <-----> | Config::Model | |-------------|
1966             |---------------|
1967              
1968             =over
1969              
1970             =item 1.
1971              
1972             A reader and writer that parse the configuration file and transform its data
1973             into a tree representation within Config::Model. The values contained in this
1974             configuration tree can be written back in the configuration file(s).
1975              
1976             =item 2.
1977              
1978             A validation engine which is in charge of validating the content and
1979             structure of configuration stored in the configuration tree. This
1980             validation engine follows the structure and constraint declared in
1981             a configuration model. This model is a kind of schema for the
1982             configuration tree.
1983              
1984             =item 3.
1985              
1986             A user interface to modify the content of the configuration tree. A
1987             modification is validated immediately by the validation engine.
1988              
1989             =back
1990              
1991             The important part is the configuration model used by the validation
1992             engine. This model can be created or modified with a graphical editor
1993             (Config::Model::Iself).
1994              
1995             =head1 Question you may ask yourself
1996              
1997             =head2 Don't we already have some configuration validation tools ?
1998              
1999             You're probably thinking of tools like webmin. Yes, these tools exist
2000             and work fine, but they have their set of drawbacks.
2001              
2002             Usually, the validation of configuration data is done with a script
2003             which performs semantic validation and often ends up being quite
2004             complex (e.g. 2500 lines for Debian's xserver-xorg.config script which
2005             handles C<xorg.conf> file).
2006              
2007             In most cases, the configuration model is expressed in instructions
2008             (whatever programming language is used) and interspersed with a lot of
2009             processing to handle the actual configuration data.
2010              
2011             =head2 What's the advantage of this project ?
2012              
2013             Config::Model projects provide a way to get a validation engine where
2014             the configuration model is completely separated from the actual
2015             processing instructions.
2016              
2017             A configuration model can be created and modified with the graphical
2018             interface provide by L<Config::Model::Itself>. The model is saved in a
2019             declarative form (currently, a Perl data structure). Such a model is
2020             easier to maintain than a lot of code.
2021              
2022             The model specifies:
2023              
2024             =over
2025              
2026             =item *
2027              
2028             The structure of the configuration data (which can be queried by
2029             generic user interfaces)
2030              
2031             =item *
2032              
2033             The properties of each element (boundaries check, integer or string,
2034             enum like type, default value ...)
2035              
2036             =item *
2037              
2038             The targeted audience (beginner, advanced, master)
2039              
2040             =item *
2041              
2042             The on-line help
2043              
2044             =back
2045              
2046             So, in the end:
2047              
2048             =over
2049              
2050             =item *
2051              
2052             Maintenance and evolution of the configuration content is easier
2053              
2054             =item *
2055              
2056             User sees a *common* interface for *all* programs using this
2057             project.
2058              
2059             =item *
2060              
2061             Upgrade of configuration data is easier and sanity check is
2062             performed during the upgrade.
2063              
2064             =item *
2065              
2066             Audit of configuration is possible to check what was modified by the
2067             user compared to default values
2068              
2069             =back
2070              
2071             =head2 What about the user interface ?
2072              
2073             L<Config::Model> interface can be:
2074              
2075             =over
2076              
2077             =item *
2078              
2079             a shell-like interface (plain or based on Term::ReadLine).
2080              
2081             =item *
2082              
2083             Graphical with L<Config::Model::TkUI> (Perl/Tk interface).
2084              
2085             =item *
2086              
2087             based on curses with L<Config::Model::CursesUI>. This interface can be
2088             handy if your X server is down.
2089              
2090             =item *
2091              
2092             Through a virtual file system where every configuration parameter is mapped to a file.
2093             (Linux only)
2094              
2095             =back
2096              
2097             All these interfaces are generated from the configuration model.
2098              
2099             And configuration model can be created or modified with a graphical
2100             user interface (with C<cme meta edit> once L<Config::Model::Itself> is
2101             installed)
2102              
2103             =head2 What about configuration data storage ?
2104              
2105             Since the syntax of configuration files vary wildly form one application
2106             to another, people who want to use this framework may have to
2107             provide a dedicated parser/writer.
2108              
2109             To help with this task, this project provides writer/parsers for common
2110             format: INI style file and perl file. With the additional
2111             Config::Model::Backend::Augeas, Augeas library can be used to read and
2112             write some configuration files. See http://augeas.net for more
2113             details.
2114              
2115             =head2 Is there an example of a configuration model ?
2116              
2117             The "example" directory contains a configuration model example for
2118             C</etc/fstab> file. This example includes a small program that use
2119             this model to show some ways to extract configuration information.
2120              
2121             =head1 Mailing lists
2122              
2123             For more question, please send a mail to:
2124              
2125             config-model-users at lists.sourceforge.net
2126              
2127             =head1 Suggested reads to start
2128              
2129             =head2 Beginners
2130              
2131             =over
2132              
2133             =item *
2134              
2135             L<Config::Model::Manual::ModelCreationIntroduction>
2136              
2137             =item *
2138              
2139             L<Config::Model::Cookbook::CreateModelFromDoc>
2140              
2141             =back
2142              
2143             =head2 Advanced
2144              
2145             =over
2146              
2147             =item *
2148              
2149             L<Config::Model::models::Itself::Class>: This doc and its siblings
2150             describes all parameters available to create a model. These are the
2151             parameters available in the GUI launched by C<cme meta edit> command.
2152              
2153             =item *
2154              
2155             L<Config::Model::Manual::ModelCreationAdvanced>
2156              
2157             =back
2158              
2159             =head2 Masters
2160              
2161             use the source, Luke
2162              
2163             =head1 STOP
2164              
2165             The documentation below is quite detailed and is more a reference doc regarding
2166             C<Config::Model> class.
2167              
2168             For an introduction to model creation, please check:
2169             L<Config::Model::Manual::ModelCreationIntroduction>
2170              
2171             =head1 Storage backend, configuration reader and writer
2172              
2173             See L<Config::Model::BackendMgr> for details
2174              
2175             =head1 Validation engine
2176              
2177             C<Config::Model> provides a way to get a validation engine from a set
2178             of rules. This set of rules is called the configuration model.
2179              
2180             =head1 User interface
2181              
2182             The user interface uses some parts of the API to set and get
2183             configuration values. More importantly, a generic user interface
2184             needs to analyze the configuration model to be able to generate at
2185             run-time relevant configuration screens.
2186              
2187             A command line interface is provided in this module. Curses and Tk
2188             interfaces are provided by L<Config::Model::CursesUI> and
2189             L<Config::Model::TkUI>.
2190              
2191             =head1 Constructor
2192              
2193             my $model = Config::Model -> new ;
2194              
2195             creates an object to host your model.
2196              
2197             =head2 Constructor parameters
2198              
2199             =over
2200              
2201             =item log_level
2202              
2203             Specify minimal log level. Default is C<WARN>. Can be C<INFO>,
2204             C<DEBUG> or C<TRACE> to get more logs. Can also be C<ERROR> to get
2205             less traces.
2206              
2207             This parameter is used to override the log level specified in log
2208             configuration file.
2209              
2210             =back
2211              
2212             =head1 Configuration Model
2213              
2214             To validate a configuration tree, we must create a configuration model
2215             that defines all the properties of the validation engine you want to
2216             create.
2217              
2218             The configuration model is expressed in a declarative form (i.e. a
2219             Perl data structure which should be easier to maintain than a lot of
2220             code)
2221              
2222             Each configuration class may contain a set of:
2223              
2224             =over
2225              
2226             =item *
2227              
2228             node elements that refer to another configuration class
2229              
2230             =item *
2231              
2232             value elements that contain actual configuration data
2233              
2234             =item *
2235              
2236             list or hash elements that also contain several node or value elements
2237              
2238             =back
2239              
2240             The structure of your configuration tree is shaped by the a set of
2241             configuration classes that are used in node elements,
2242              
2243             The structure of the configuration data must be based on a tree
2244             structure. This structure has several advantages:
2245              
2246             =over
2247              
2248             =item *
2249              
2250             Unique path to get to a node or a leaf.
2251              
2252             =item *
2253              
2254             Simpler exploration and query
2255              
2256             =item *
2257              
2258             Simple hierarchy. Deletion of configuration items is simpler to grasp:
2259             when you cut a branch, all the leaves attached to that branch go down.
2260              
2261             =back
2262              
2263             But using a tree has also some drawbacks:
2264              
2265             =over 4
2266              
2267             =item *
2268              
2269             A complex configuration cannot be mapped on a tree. Some more
2270             relation between nodes and leaves must be added.
2271              
2272             =item *
2273              
2274             A configuration may actually be structured as a graph instead as a tree (for
2275             instance, any configuration that maps a service to a
2276             resource). The graph relation must be decomposed in a tree with
2277             special I<reference> relations that complete the tree to form a graph.
2278             See L<Config::Model::Value/Value Reference>
2279              
2280             =back
2281              
2282             Note: a configuration tree is a tree of objects. The model is declared
2283             with classes. The classes themselves have relations that closely match
2284             the relation of the object of the configuration tree. But the class
2285             need not to be declared in a tree structure (always better to reuse
2286             classes). But they must be declared as a DAG (directed acyclic graph).
2287             See also
2288             L<Directed acyclic graph on Wikipedia|http://en.wikipedia.org/wiki/Directed_acyclic_graph">More on DAGs>
2289              
2290             Each configuration class declaration specifies:
2291              
2292             =over
2293              
2294             =item *
2295              
2296             The C<name> of the class (mandatory)
2297              
2298             =item *
2299              
2300             A C<class_description> used in user interfaces (optional)
2301              
2302             =item *
2303              
2304             Optional include specification to avoid duplicate declaration of elements.
2305              
2306             =item *
2307              
2308             The class elements
2309              
2310             =back
2311              
2312             Each element specifies:
2313              
2314             =over
2315              
2316             =item *
2317              
2318             Most importantly, the type of the element (mostly C<leaf>, or C<node>)
2319              
2320             =item *
2321              
2322             The properties of each element (boundaries, check, integer or string,
2323             enum like type ...)
2324              
2325             =item *
2326              
2327             The default values of parameters (if any)
2328              
2329             =item *
2330              
2331             Whether the parameter is mandatory
2332              
2333             =item *
2334              
2335             Targeted audience (beginner, advance, master), i.e. the level of
2336             expertise required to tinker a parameter (to hide expert parameters
2337             from newbie eyes)
2338              
2339             =item *
2340              
2341             On-line help (for each parameter or value of parameter)
2342              
2343             =back
2344              
2345             See L<Config::Model::Node> for details on how to declare a
2346             configuration class.
2347              
2348             Example:
2349              
2350             $ cat lib/Config/Model/models/Xorg.pl
2351             [
2352             {
2353             name => 'Xorg',
2354             class_description => 'Top level Xorg configuration.',
2355             include => [ 'Xorg::ConfigDir'],
2356             element => [
2357             Files => {
2358             type => 'node',
2359             description => 'File pathnames',
2360             config_class_name => 'Xorg::Files'
2361             },
2362             # snip
2363             ]
2364             },
2365             {
2366             name => 'Xorg::DRI',
2367             element => [
2368             Mode => {
2369             type => 'leaf',
2370             value_type => 'uniline',
2371             description => 'DRI mode, usually set to 0666'
2372             }
2373             ]
2374             }
2375             ];
2376              
2377             =head1 Configuration instance methods
2378              
2379             A configuration instance is created from a model and is the starting
2380             point of a configuration tree.
2381              
2382             =head2 instance
2383              
2384             An instance must be created with a model name (using the root class
2385             name) or an application name (as shown by "L<cme> C<list>" command).
2386              
2387             For example:
2388              
2389             my $model = Config::Model->new() ;
2390             $model->instance( application => 'approx');
2391              
2392             Or:
2393              
2394             my $model = Config::Model->new() ;
2395             # note that the model class is slightly different compared to
2396             # application name
2397             $model->instance( root_class_name => 'Approx');
2398              
2399             A custom configuration class can also be used with C<root_class_name> parameter:
2400              
2401             my $model = Config::Model->new() ;
2402             # create_config_class is described below
2403             $model ->create_config_class (
2404             name => "SomeRootClass",
2405             element => [ ... ]
2406             ) ;
2407              
2408             # instance name is 'default'
2409             my $inst = $model->instance (root_class_name => 'SomeRootClass');
2410              
2411             You can create several separated instances from a model using
2412             C<name> option:
2413              
2414             # instance name is 'default'
2415             my $inst = $model->instance (
2416             root_class_name => 'SomeRootClass',
2417             name => 'test1'
2418             );
2419              
2420             Usually, model files are loaded automatically using a path matching
2421             C<root_class_name> (e.g. configuration class C<Foo::Bar> is stored in
2422             C<Foo/Bar.pl>. You can choose to specify the file containing
2423             the model with C<model_file> parameter. This is mostly useful for
2424             tests.
2425              
2426             The C<instance> method can also retrieve an instance that has already
2427             been created:
2428              
2429             my $inst = $model->instance( name => 'test1' );
2430              
2431             =head2 get_instance
2432              
2433             Retrieve an existing instance using its name.
2434              
2435             my $inst = $model->get_instance('test1' );
2436              
2437             =head2 has_instance
2438              
2439             Check if an instance name already exists
2440              
2441             my $maybe = $model->has_instance('test1');
2442              
2443             =head2 cme
2444              
2445             This method is syntactic sugar for short program. It creates a new
2446             C<Config::Model> object and returns a new instance.
2447              
2448             C<cme> arguments are passed to L</instance> method, except
2449             C<force-load>.
2450              
2451             Like L<cme> command, C<cme> functions accepts C<force-load>
2452             parameters. When this argument is true, the instance is created with
2453             C<check => 'no'>. Hence bad values are stored in C<cme> and must be
2454             corrected before saving back the data.
2455              
2456             =head1 Configuration class
2457              
2458             A configuration class is made of series of elements which are detailed
2459             in L<Config::Model::Node>.
2460              
2461             Whatever its type (node, leaf,... ), each element of a node has
2462             several other properties:
2463              
2464             =over
2465              
2466             =item level
2467              
2468             Level is C<important>, C<normal> or C<hidden>.
2469              
2470             The level is used to set how configuration data is presented to the
2471             user in browsing mode. C<Important> elements are shown to the user no
2472             matter what. C<hidden> elements are well, hidden. Their purpose is
2473             explained with the I<warp> notion.
2474              
2475             =item status
2476              
2477             Status is C<obsolete>, C<deprecated> or C<standard> (default).
2478              
2479             Using a deprecated element raises a warning. Using an obsolete
2480             element raises an exception.
2481              
2482             =item description
2483              
2484             Description of the element. This description is used while
2485             generating user interfaces.
2486              
2487             =item summary
2488              
2489             Summary of the element. This description is used while generating
2490             a user interfaces and may be used in comments when writing the
2491             configuration file.
2492              
2493             =item class_description
2494              
2495             Description of the configuration class. This description is used
2496             while generating user interfaces.
2497              
2498             =item generated_by
2499              
2500             Mention with a descriptive string if this class was generated by a
2501             program. This parameter is currently reserved for
2502             L<Config::Model::Itself> model editor.
2503              
2504             =item include
2505              
2506             Include element description from another class.
2507              
2508             include => 'AnotherClass' ,
2509              
2510             or
2511              
2512             include => [qw/ClassOne ClassTwo/]
2513              
2514             In a configuration class, the order of the element is important. For
2515             instance if C<foo> is warped by C<bar>, you must declare C<bar>
2516             element before C<foo>.
2517              
2518             When including another class, you may wish to insert the included
2519             elements after a specific element of your including class:
2520              
2521             # say AnotherClass contains element xyz
2522             include => 'AnotherClass' ,
2523             include_after => "foo" ,
2524             element => [ bar => ... , foo => ... , baz => ... ]
2525              
2526             Now the element of your class are:
2527              
2528             ( bar , foo , xyz , baz )
2529              
2530             Note that include may not clobber an existing element.
2531              
2532             =item include_backend
2533              
2534             Include read/write specification from another class.
2535              
2536             include_backend => 'AnotherClass' ,
2537              
2538             or
2539              
2540             include_backend => [qw/ClassOne ClassTwo/]
2541              
2542             =back
2543              
2544             Note that include may not clobber an existing read/write specification.
2545              
2546             =head2 create_config_class
2547              
2548             This method creates configuration classes. The parameters are
2549             described above and are forwarded to L<Config::Model::Node>
2550             constructor. See
2551             L<Config::Model::Node/"Configuration class declaration">
2552             for more details on configuration class parameters.
2553              
2554             Example:
2555              
2556             my $model = Config::Model -> new ;
2557              
2558             $model->create_config_class
2559             (
2560             config_class_name => 'SomeRootClass',
2561             description => [ X => 'X-ray' ],
2562             level => [ 'tree_macro' => 'important' ] ,
2563             class_description => "SomeRootClass description",
2564             element => [ ... ]
2565             ) ;
2566              
2567             For convenience, C<level> and C<description> parameters
2568             can also be declared within the element declaration:
2569              
2570             $model->create_config_class
2571             (
2572             config_class_name => 'SomeRootClass',
2573             class_description => "SomeRootClass description",
2574             'element'
2575             => [
2576             tree_macro => { level => 'important'},
2577             X => { description => 'X-ray', } ,
2578             ]
2579             ) ;
2580              
2581             =head1 Load predeclared model
2582              
2583             You can also load predeclared model.
2584              
2585             =head2 load( <model_name> )
2586              
2587             This method opens the model directory and execute a C<.pl>
2588             file containing the model declaration,
2589              
2590             This perl file must return an array ref to declare models. E.g.:
2591              
2592             [
2593             [
2594             name => 'Class_1',
2595             element => [ ... ]
2596             ],
2597             [
2598             name => 'Class_2',
2599             element => [ ... ]
2600             ]
2601             ];
2602              
2603             do not put C<1;> at the end or C<load> will not work
2604              
2605             When a model name contain a C<::> (e.g C<Foo::Bar>), C<load> looks for
2606             a file named C<Foo/Bar.pl>.
2607              
2608             This method also searches in C<Foo/Bar.d> directory for additional model information.
2609             Model snippet found there are loaded with L<augment_config_class>.
2610              
2611             Returns a list containing the names of the loaded classes. For instance, if
2612             C<Foo/Bar.pl> contains a model for C<Foo::Bar> and C<Foo::Bar2>, C<load>
2613             returns C<( 'Foo::Bar' , 'Foo::Bar2' )>.
2614              
2615             =head2 augment_config_class (name => '...', class_data )
2616              
2617             Enhance the feature of a configuration class. This method uses the same parameters
2618             as L<create_config_class>. See
2619             L<Config::Model::Manual::ModelCreationAdvanced/"Model Plugin">
2620             for more details on creating model plugins.
2621              
2622             =head1 Model query
2623              
2624             =head2 model
2625              
2626             Returns a hash containing the model declaration of the passed model
2627             name. Do not modify the content of the returned data structure.
2628              
2629             my $cloned = $model->model('Foo');
2630              
2631             =head2 get_model_clone
2632              
2633             Like C<model>, returns a hash containing the model declaration of the passed model
2634             name, this time in a deep clone of the data structure.
2635              
2636             my $cloned = $model->get_model_clone('Foo');
2637              
2638             =head2 generate_doc ( top_class_name , directory , [ \%done ] )
2639              
2640             Generate POD document for configuration class top_class_name and all
2641             classes used by top_class_name, and write them in specified directory.
2642              
2643             C<\%done> is an optional reference to a hash used to avoid writing
2644             twice the same documentation when this method is called several times.
2645              
2646             =head2 get_element_model( config_class_name , element)
2647              
2648             Return a hash containing the model declaration for the specified class
2649             and element.
2650              
2651             =head2 get_element_name( class => Foo )
2652              
2653             Get all names of the elements of class C<Foo>.
2654              
2655             =head2 get_element_property
2656              
2657             Returns the property of an element from the model.
2658              
2659             Parameters are:
2660              
2661             =over
2662              
2663             =item class
2664              
2665             =item element
2666              
2667             =item property
2668              
2669             =back
2670              
2671             =head2 list_class_element
2672              
2673             Returns a string listing all the class and elements. Useful for
2674             debugging your configuration model.
2675              
2676             =head1 Error handling
2677              
2678             Errors are handled with an exception mechanism.
2679              
2680             When a strongly typed Value object gets an authorized value, it raises
2681             an exception. If this exception is not caught, the programs exits.
2682              
2683             See L<Config::Model::Exception|Config::Model::Exception> for details on
2684             the various exception classes provided with C<Config::Model>.
2685              
2686             =head1 Logging
2687              
2688             See L<cme/Logging>
2689              
2690             =head2 initialize_log4perl
2691              
2692             This method can be called to load L<Log::Log4perl> configuration from
2693             C<~/.log4config-model>, or from C</etc/log4config-model.conf> files or from
2694             L<default configuration|https://github.com/dod38fr/config-model/blob/master/lib/Config/Model/log4perl.conf>.
2695              
2696             Accepts C<verbose> parameter with a list of log classes that are added
2697             to the log4perl configuration read above.
2698              
2699             For instance, with C<< verbose => 'Loader' >>, log4perl is initialised with
2700              
2701             log4perl.logger.Verbose.Loader = INFO, PlainMsgOnScreen
2702              
2703             Likewise, with C<< verbose => [ 'Loader', 'Foo' ] >>,
2704             log4perl is initialised with:
2705              
2706             log4perl.logger.Verbose.Loader = INFO, PlainMsgOnScreen
2707             log4perl.logger.Verbose.Foo = INFO, PlainMsgOnScreen
2708              
2709             Currently, this module supports only C<Loader> as verbose parameters.
2710              
2711             =head1 BUGS
2712              
2713             Given Murphy's law, the author is fairly confident that you will find
2714             bugs or miss some features. Please report them to
2715             https://github.com/dod38fr/config-model/issues
2716             The author will be notified, and then you'll automatically be
2717             notified of progress on your bug.
2718              
2719             =head1 FEEDBACK
2720              
2721             Feedback from users are highly desired. If you find this module useful, please
2722             share your use cases, success stories with the author or with the config-model-
2723             users mailing list.
2724              
2725             =head1 PROJECT FOUNDER
2726              
2727             Dominique Dumont, "ddumont@cpan.org"
2728              
2729             =head1 CREDITS
2730              
2731             Contributors to this project are listed in alphabetical order:
2732              
2733             Harley Pig
2734              
2735             Ilya Arosov
2736              
2737             Jose Luis Perez Diez
2738              
2739             Krzysztof Tyszecki
2740              
2741             Mathieu Arnold
2742              
2743             Mohammad S Anwar
2744              
2745             Topi Miettinen
2746              
2747             Many thanks for your help
2748              
2749             =head1 SEE ALSO
2750              
2751             L<Config::Model::Instance>,
2752              
2753             L<https://github.com/dod38fr/config-model/wiki>
2754              
2755             L<https://github.com/dod38fr/config-model/wiki/Creating-models>
2756              
2757             =head2 Model elements
2758              
2759             The arrow shows inheritance between classes
2760              
2761             =over
2762              
2763             =item *
2764              
2765             L<Config::Model::Node> <- L<Config::Model::AnyThing>
2766              
2767             =item *
2768              
2769             L<Config::Model::HashId> <- L<Config::Model::AnyId> <- L<Config::Model::AnyThing>
2770              
2771             =item *
2772              
2773             L<Config::Model::ListId> <- L<Config::Model::AnyId> <- L<Config::Model::AnyThing>
2774              
2775             =item *
2776              
2777             L<Config::Model::Value> <- L<Config::Model::AnyThing>
2778              
2779             =item *
2780              
2781             L<Config::Model::CheckList> <- L<Config::Model::AnyThing>
2782              
2783             =item *
2784              
2785             L<Config::Model::WarpedNode> <- L<Config::Model::AnyThing>
2786              
2787             =back
2788              
2789             =head2 command line
2790              
2791             L<cme>.
2792              
2793             =head2 Read and write backends
2794              
2795             =over
2796              
2797             =item *
2798              
2799             L<Config::Model::Backend::Fstab> <- L<Config::Model::Backend::Any>
2800              
2801             =item *
2802              
2803             L<Config::Model::Backend::IniFile> <- L<Config::Model::Backend::Any>
2804              
2805             =item *
2806              
2807             L<Config::Model::Backend::PlainFile> <- L<Config::Model::Backend::Any>
2808              
2809             =item *
2810              
2811             L<Config::Model::Backend::ShellVar> <- L<Config::Model::Backend::Any>
2812              
2813             =back
2814              
2815             =head2 Model utilities
2816              
2817             =over
2818              
2819             =item *
2820              
2821             L<Config::Model::Annotation>
2822              
2823             =item *
2824              
2825             L<Config::Model::BackendMgr>: Used by C<Config::Model::Node> object
2826              
2827             =item *
2828              
2829             L<Config::Model::Describe>
2830              
2831             =item *
2832              
2833             L<Config::Model::Dumper>
2834              
2835             =item *
2836              
2837             L<Config::Model::DumpAsData>
2838              
2839             =item *
2840              
2841             L<Config::Model::IdElementReference>
2842              
2843             =item *
2844              
2845             L<Config::Model::Iterator>
2846              
2847             =item *
2848              
2849             L<Config::Model::Loader>
2850              
2851             =item *
2852              
2853             L<Config::Model::ObjTreeScanner>
2854              
2855             =item *
2856              
2857             L<Config::Model::Report>
2858              
2859             =item *
2860              
2861             L<Config::Model::Searcher>: Search element in configuration model.
2862              
2863             =item *
2864              
2865             L<Config::Model::SimpleUI>
2866              
2867             =item *
2868              
2869             L<Config::Model::TreeSearcher>: Search string or regexp in configuration tree.
2870              
2871             =item *
2872              
2873             L<Config::Model::TermUI>
2874              
2875             =item *
2876              
2877             L<Config::Model::Iterator>
2878              
2879             =item *
2880              
2881             L<Config::Model::ValueComputer>
2882              
2883             =item *
2884              
2885             L<Config::Model::Warper>
2886              
2887             =back
2888              
2889             =head2 Test framework
2890              
2891             =over
2892              
2893             =item *
2894              
2895             L<Config::Model::Tester>
2896              
2897             =back
2898              
2899             =head1 AUTHOR
2900              
2901             Dominique Dumont
2902              
2903             =head1 COPYRIGHT AND LICENSE
2904              
2905             This software is Copyright (c) 2005-2022 by Dominique Dumont.
2906              
2907             This is free software, licensed under:
2908              
2909             The GNU Lesser General Public License, Version 2.1, February 1999
2910              
2911             =for :stopwords cpan testmatrix url bugtracker rt cpants kwalitee diff irc mailto metadata placeholders metacpan
2912              
2913             =head1 SUPPORT
2914              
2915             =head2 Websites
2916              
2917             The following websites have more information about this module, and may be of help to you. As always,
2918             in addition to those websites please use your favorite search engine to discover more resources.
2919              
2920             =over 4
2921              
2922             =item *
2923              
2924             CPANTS
2925              
2926             The CPANTS is a website that analyzes the Kwalitee ( code metrics ) of a distribution.
2927              
2928             L<http://cpants.cpanauthors.org/dist/Config-Model>
2929              
2930             =item *
2931              
2932             CPAN Testers
2933              
2934             The CPAN Testers is a network of smoke testers who run automated tests on uploaded CPAN distributions.
2935              
2936             L<http://www.cpantesters.org/distro/C/Config-Model>
2937              
2938             =item *
2939              
2940             CPAN Testers Matrix
2941              
2942             The CPAN Testers Matrix is a website that provides a visual overview of the test results for a distribution on various Perls/platforms.
2943              
2944             L<http://matrix.cpantesters.org/?dist=Config-Model>
2945              
2946             =item *
2947              
2948             CPAN Testers Dependencies
2949              
2950             The CPAN Testers Dependencies is a website that shows a chart of the test results of all dependencies for a distribution.
2951              
2952             L<http://deps.cpantesters.org/?module=Config::Model>
2953              
2954             =back
2955              
2956             =head2 Bugs / Feature Requests
2957              
2958             Please report any bugs or feature requests by email to C<ddumont at cpan.org>, or through
2959             the web interface at L<https://github.com/dod38fr/config-model/issues>. You will be automatically notified of any
2960             progress on the request by the system.
2961              
2962             =head2 Source Code
2963              
2964             The code is open to the world, and available for you to hack on. Please feel free to browse it and play
2965             with it, or whatever. If you want to contribute patches, please send me a diff or prod me to pull
2966             from your repository :)
2967              
2968             L<http://github.com/dod38fr/config-model>
2969              
2970             git clone git://github.com/dod38fr/config-model.git
2971              
2972             =cut