File Coverage

blib/lib/Config/Model/Itself.pm
Criterion Covered Total %
statement 368 405 90.8
branch 59 112 52.6
condition 56 105 53.3
subroutine 36 40 90.0
pod 6 18 33.3
total 525 680 77.2


line stmt bran cond sub pod time code
1             #
2             # This file is part of Config-Model-Itself
3             #
4             # This software is Copyright (c) 2007-2017 by Dominique Dumont.
5             #
6             # This is free software, licensed under:
7             #
8             # The GNU Lesser General Public License, Version 2.1, February 1999
9             #
10             package Config::Model::Itself ;
11             $Config::Model::Itself::VERSION = '2.013';
12 8     8   2200078 use Mouse ;
  8         64  
  8         52  
13 8     8   2810 use Config::Model 2.114;
  8         154  
  8         248  
14 8     8   99 use 5.010;
  8         27  
15              
16 8     8   34 use IO::File ;
  8         16  
  8         954  
17 8     8   54 use Log::Log4perl 1.11;
  8         107  
  8         38  
18 8     8   307 use Carp ;
  8         14  
  8         379  
19 8     8   50 use Data::Dumper ;
  8         13  
  8         298  
20 8     8   43 use File::Find ;
  8         21  
  8         373  
21 8     8   42 use File::Path ;
  8         21  
  8         332  
22 8     8   45 use File::Basename ;
  8         17  
  8         399  
23 8     8   2358 use Data::Compare ;
  8         63217  
  8         42  
24 8     8   20660 use Path::Tiny 0.062;
  8         175  
  8         363  
25 8     8   47 use Mouse::Util::TypeConstraints;
  8         11  
  8         88  
26              
27             my $logger = Log::Log4perl::get_logger("Backend::Itself");
28              
29             subtype 'ModelPathTiny' => as 'Object' => where { $_->isa('Path::Tiny') };
30              
31             coerce 'ModelPathTiny' => from 'Str' => via {path($_)} ;
32              
33             # find all .pl file in model_dir and load them...
34              
35             around BUILDARGS => sub {
36             my $orig = shift;
37             my $class = shift;
38             my %args = @_;
39              
40             my $legacy = delete $args{model_object};
41             if ($legacy) {
42             $args{config_model} = $legacy->instance->config_model;
43             $args{meta_instance} = $legacy->instance;
44             $args{meta_root} = $legacy;
45             }
46             return $class->$orig( %args );
47             };
48              
49             has 'config_model' => (
50             is => 'ro',
51             isa => 'Config::Model',
52             lazy_build => 1,
53             ) ;
54              
55              
56             sub _build_config_model {
57 0     0   0 my $self = shift;
58             # don't trigger builders below
59 0 0       0 if ($self->{meta_root}) {
    0          
60 0         0 return $self->meta_root->instance->config_model;
61             }
62             elsif ($self->{meta_instance}) {
63 0         0 return $self->meta_instance->config_model;
64             }
65             else {
66 0         0 return Config::Model -> new ( ) ;
67             }
68             }
69              
70             has check => (is =>'ro', isa => 'Bool', default => 1) ;
71              
72             has 'meta_instance' => (
73             is =>'ro',
74             isa =>'Config::Model::Instance',
75             lazy_build => 1,
76             ) ;
77              
78             sub _build_meta_instance {
79 0     0   0 my $self = shift;
80              
81             # don't trigger builders below
82 0 0       0 if ($self->{meta_root}) {
83 0         0 return $self->meta_root->instance;
84             }
85             else {
86             # load Config::Model model
87 0         0 return $self->config_model->instance (
88             root_class_name => 'Itself::Model' ,
89             instance_name => 'meta_model' ,
90             check => $self->check,
91             );
92             }
93              
94             }
95              
96             has meta_root => (
97             is =>'ro',
98             isa =>'Config::Model::Node',
99             lazy_build => 1,
100             ) ;
101              
102             sub _build_meta_root {
103 0     0   0 my $self = shift;
104              
105 0         0 return $self->meta_instance -> config_root ;
106             }
107              
108             has cm_lib_dir => (
109             is =>'ro',
110             isa => 'ModelPathTiny',
111             lazy_build => 1,
112             coerce => 1
113             ) ;
114              
115             sub _build_cm_lib_dir {
116 0     0   0 my $self = shift;
117 0         0 my $p = path('lib/Config/Model');
118 0 0       0 if (! $p->is_dir) {
119 0 0       0 $p->mkpath(0, 0755) || die "can't create $p:$!";
120             }
121 0         0 return $p;
122             }
123              
124             has force_write => (is =>'ro', isa => 'Bool', default => 0) ;
125             has root_model => (is =>'ro', isa => 'str');
126              
127             has modified_classes => (
128             is =>'rw',
129             isa =>'HashRef[Bool]',
130             traits => ['Hash'],
131             default => sub { {} } ,
132             handles => {
133             clear_classes => 'clear',
134             set_class => 'set',
135             class_was_changed => 'get' ,
136             class_known => 'exists',
137             }
138             ) ;
139              
140             has model_dir => (
141             is => 'ro',
142             isa => 'ModelPathTiny',
143             lazy_build => 1,
144             );
145              
146             sub _build_model_dir {
147 9     9   19 my $self = shift;
148 9         67 my $md = $self->cm_lib_dir->child('models');
149 9         352 $md->mkpath;
150 9         1153 return $md;
151             }
152              
153             sub BUILD {
154 9     9 1 22 my $self = shift;
155              
156             my $cb = sub {
157 6574     6574   19949551 my %args = @_ ;
158 6574   50     20860 my $p = $args{path} || '' ;
159 6574 100       29528 return unless $p =~ /^class/ ;
160 6569 100       14510 return unless $args{index}; # may be empty when class order is changed
161 6462 100       19035 return if $self->class_was_changed($args{index}) ;
162 885         14023 $logger->info("class $args{index} was modified");
163              
164 885         8380 $self->add_modified_class($args{index}) ;
165 9         48 } ;
166 9         89 $self->meta_instance -> on_change_cb($cb) ;
167              
168             }
169              
170             sub add_tracked_class {
171 123     123 0 174 my $self = shift;
172 123         299 $self->set_class(shift,0) ;
173             }
174              
175             sub add_modified_class {
176 1008     1008 0 7009 my $self = shift;
177 1008         3045 $self->set_class(shift,1) ;
178             }
179              
180             sub class_needs_write {
181 65     65 0 128 my $self = shift;
182 65         113 my $name = shift;
183 65   66     460 return ($self->force_write or not $self->class_known($name) or $self->class_was_changed($name)) ;
184             }
185              
186             sub read_app_files {
187 7     7 0 17 my $self = shift;
188 7   100     31 my $force_load = shift || 0;
189 7         14 my $read_from = shift ;
190 7         10 my $application = shift ;
191              
192 7   33     60 my $app_dir = $read_from || $self->model_dir->parent;
193 7         494 my %apps;
194 7         29 $logger->info("reading app files from ".$app_dir);
195 7         124 foreach my $dir ( $app_dir->children(qr/\.d$/) ) {
196              
197 3         332 $logger->info("reading app dir ".$dir);
198 3         34 foreach my $file ( $dir->children() ) {
199 3 50       231 next if $file =~ m!/README!;
200 3 50       25 next if $file =~ /(~|\.bak|\.orig)$/;
201 3 50 33     32 next if $application and $file->basename ne $application;
202              
203             # bad categories are filtered by the model
204 3         12 my %data = ( category => $dir->basename('.d') );
205 3         149 $logger->info("reading app file ".$file);
206              
207 3         41 foreach ($file->lines({ chomp => 1})) {
208 6         512 s/^\s+//;
209 6         18 s/\s+$//;
210 6         11 s/#.*//;
211 6         27 my ( $k, $v ) = split /\s*=\s*/;
212 6 50       16 next unless $v;
213 6         15 $data{$k} = $v;
214             }
215              
216 3         12 my $appli = $file->basename;
217 3         118 $apps{$appli} = $data{model} ;
218              
219 3 50       36 $self->meta_root->load_data(
220             data => { application => { $appli => \%data } },
221             check => $force_load ? 'no' : 'yes'
222             ) ;
223             }
224             }
225              
226 7         144317 return \%apps;
227             }
228              
229             sub read_all {
230 7     7 0 83 my $self = shift ;
231 7         25 my %args = @_ ;
232              
233 7   100     43 my $force_load = delete $args{force_load} || 0 ;
234 7         15 my $read_from ;
235             my $model_dir ;
236 7 50       26 if ($args{read_from}) {
237 0         0 $read_from = path (delete $args{read_from});
238 0 0       0 die "Cannot read from unknown dir ".$read_from unless $read_from->is_dir;
239 0         0 $model_dir = $read_from->child('models');
240 0 0       0 die "Cannot read from unknown dir ".$model_dir unless $model_dir->is_dir;
241             }
242              
243 7         32 my $apps = $self-> read_app_files($force_load, $read_from, delete $args{application});
244              
245 7   50     35 my $root_model_arg = delete $args{root_model} || '';
246 7   33     45 my $model = $apps->{$root_model_arg} || $root_model_arg ;
247 7         18 my $legacy = delete $args{legacy} ;
248              
249 7 50       20 croak "read_all: unexpected parameters ",join(' ', keys %args) if %args ;
250              
251 7         27 my $dir = $self->model_dir;
252 7         31 $dir->mkpath ;
253              
254 7         413 my $root_model_file = $model ;
255 7         21 $root_model_file =~ s!::!/!g ;
256 7   33     45 my $read_dir = $model_dir || $dir;
257 7         31 $logger->info("searching model files in ".$read_dir);
258              
259 7         83 my @files ;
260             my $wanted = sub {
261 103 50 100 103   8855 push @files, $_ if ( $_->is_file and /\.pl$/
      66        
      66        
262             and m!$read_dir/$root_model_file\b!
263             and not m!\.d/!
264             ) ;
265 7         36 } ;
266 7         46 $read_dir->visit($wanted, { recurse => 1} ) ;
267              
268 7         431 my $i = $self->meta_instance ;
269              
270 7         36 my %read_models ;
271             my %pod_data ;
272 7         0 my %class_file_map ;
273              
274 7         0 my @all_models;
275 7         21 for my $file (@files) {
276 63         301 $logger->info("loading config file $file");
277              
278             # now apply some translation to read model
279             # - translate legacy warp parameters
280             # - expand elements name
281 63 100       914 my @legacy = $legacy ? ( legacy => $legacy ) : () ;
282 63         612 my $tmp_model = Config::Model -> new( skip_include => 1, @legacy ) ;
283              
284             # @models order is important to write configuration class back in the same
285             # order as the declaration
286 63         4476 my @models = $tmp_model -> load ( 'Tmp' , $file->absolute ) ;
287 63         235148 push @all_models, @models;
288              
289 63         187 my $rel_file = $file ;
290 63         266 $rel_file =~ s/^$read_dir\/?//;
291 63 50       1031 die "wrong reg_exp" if $file eq $rel_file ;
292 63         365 $class_file_map{$rel_file} = \@models ;
293              
294             # - move experience, description and level status into parameter info.
295 63         148 foreach my $model_name (@models) {
296             # no need to dclone model as Config::Model object is temporary
297 123         340 my $raw_model = $tmp_model -> get_raw_model( $model_name ) ;
298 123         1938 my $new_model = $tmp_model -> get_model( $model_name ) ;
299              
300 123         26305 $self->upgrade_model($model_name, $new_model);
301              
302             # track read class to identify later classes added by user
303 123         320 $self->add_tracked_class($model_name);
304              
305             # some modifications may be done to cope with older model styles. If a modif
306             # was done, mark the class as changed so it will be saved later
307 123 50       4871 $self->add_modified_class($model_name) unless Compare($raw_model, $new_model) ;
308              
309 123         4090 foreach my $item (qw/description summary level experience status/) {
310 615         711 foreach my $elt_name (keys %{$new_model->{element}}) {
  615         1327  
311 3810         4913 my $moved_data = delete $new_model->{$item}{$elt_name} ;
312 3810 50       5790 next unless defined $moved_data ;
313 0         0 $new_model->{element}{$elt_name}{$item} = $moved_data ;
314             }
315 615         1170 delete $new_model->{$item} ;
316             }
317              
318             # Since accept specs and elements are stored in a ordered hash,
319             # load_data expects a array ref instead of a hash ref.
320             # Build this array ref taking the order into
321             # account
322 123         190 foreach my $what (qw/element accept/) {
323 246         500 my $list = delete $new_model -> {$what.'_list'} ;
324 246         383 my $h = delete $new_model -> {$what} ;
325 246         425 $new_model -> {$what} = [] ;
326             map {
327 246         450 push @{$new_model->{$what}}, $_, $h->{$_}
  768         926  
  768         1859  
328             } @$list ;
329             }
330              
331             # remove hash key with undefined values
332 123         306 map { delete $new_model->{$_} unless defined $new_model->{$_}
333 351 50 33     1449 and $new_model->{$_} ne ''
334             } keys %$new_model ;
335 123         3738 $read_models{$model_name} = $new_model ;
336             }
337              
338             }
339              
340 7   33     180 $self->{root_model} = $model || (sort @all_models)[0];
341              
342             # Create all classes listed in %read_models to avoid problems with
343             # include statement while calling load_data
344 7         35 my $root_obj = $self->meta_root ;
345 7         44 my $class_element = $root_obj->fetch_element('class') ;
346 7         100382 map { $class_element->fetch_with_id($_) } sort keys %read_models ;
  123         2663  
347              
348             #require Tk::ObjScanner; Tk::ObjScanner::scan_object(\%read_models) ;
349              
350 7         190 $logger->info("loading all extracted data in Config::Model::Itself");
351             # load with a array ref to avoid warnings about missing order
352 7 100       163 $root_obj->load_data(
353             data => {class => [ %read_models ] },
354             check => $force_load ? 'no' : 'yes'
355             ) ;
356              
357             # load annotations and comment header
358 7         29199 for my $file (@files) {
359 63         245 $logger->info("loading annotations from file $file");
360 63   50     1011 my $fh = IO::File->new($file) || die "Can't open $file: $!" ;
361 63         6287 my @lines = $fh->getlines ;
362 63         6658 $fh->close;
363 63         1778 $root_obj->load_pod_annotation(join('',@lines)) ;
364              
365 63         69301 my @headers ;
366 63         154 foreach my $l (@lines) {
367 981 100 100     2871 if ($l =~ /^\s*#/ or $l =~ /^\s*$/){
368 918         1669 push @headers, $l
369             }
370             else {
371 63         116 last;
372             }
373             }
374 63         122 my $rel_file = $file ;
375 63         318 $rel_file =~ s/^$dir\/?//;
376 63         2124 $self->{header}{$rel_file} = \@headers;
377             }
378              
379 7         2067 return $self->{map} = \%class_file_map ;
380             }
381              
382             # can be removed end of 2019 (after buster is released)
383             sub upgrade_model {
384 123     123 0 278 my ($self, $config_class_name, $model) = @_ ;
385              
386 123         194 my $multi_backend = 0;
387 123         223 foreach my $config (qw/read_config write_config/) {
388 246         387 my $ref = $model->{$config};
389 246 50 33     539 if ($ref and ref($ref) eq 'ARRAY') {
390 0 0       0 if (@$ref == 1) {
    0          
391 0         0 $model->{$config} = $ref->[0];
392             }
393             elsif (@$ref > 1){
394 0         0 $logger->warn("$config_class_name $config: cannot migrate multiple backends to rw_config");
395 0         0 $multi_backend++;
396             }
397             }
398             }
399              
400 123 50 33     260 if ($model->{read_config} and not $multi_backend) {
401 0         0 say ("Model $config_class_name: moving read_config specification to rw_config");
402 0         0 $model->{rw_config} = delete $model->{read_config};
403             }
404              
405 123 50 33     316 if ($model->{write_config} and not $multi_backend) {
406 0         0 say "Model $config_class_name: merging write_config specification in rw_config";
407 0 0       0 if (not $multi_backend) {
408 0         0 map {$model->{rw_config}{$_} = $model->{write_config}{$_} } keys %{$model->{write_config}} ;
  0         0  
  0         0  
409 0         0 delete $model->{write_config};
410             }
411             }
412             }
413              
414             # internal
415             sub get_perl_data_model{
416 66     66 0 1848635 my $self = shift ;
417 66         230 my %args = @_ ;
418 66         171 my $root_obj = $self->{meta_root};
419             my $class_name = $args{class_name}
420 66   33     227 || croak __PACKAGE__," read: undefined class name";
421              
422 66         246 my $class_element = $root_obj->fetch_element('class') ;
423              
424             # skip if class was deleted during edition
425 66 50       3710 return unless $class_element->defined($class_name) ;
426              
427 66         922 my $class_elt = $class_element -> fetch_with_id($class_name) ;
428              
429 66         3202 my $model = $class_elt->dump_as_data ;
430              
431             # now apply some translation to read model
432             # - Do NOT translate legacy warp parameters
433             # - Do not compact elements name
434              
435             # don't forget to add name
436 66 50       4484684 $model->{name} = $class_name if keys %$model;
437              
438 66         311 return $model ;
439             }
440              
441             sub write_app_files {
442 4     4 0 10 my $self = shift;
443              
444 4         12 my $app_dir = $self->cm_lib_dir;
445 4         19 my $app_obj = $self->meta_root->fetch_element('application');
446              
447 4         626 foreach my $app_name ( $app_obj->fetch_all_indexes ) {
448 2         45 my $app = $app_obj->fetch_with_id($app_name);
449 2         83 my $cat_dir_name = $app->fetch_element_value( name =>'category' ).'.d';
450 2         437 $app_dir->child($cat_dir_name)->mkpath();
451 2         276 my $app_file = $app_dir->child($cat_dir_name)->child($app->index_value) ;
452              
453 2         110 my @lines ;
454 2         35 foreach my $name ( $app->children ) {
455 20 100       353 next if $name eq 'category'; # saved as directory above
456              
457 18         50 my $v = $app->fetch_element_value($name); # need to spit out 0 ?
458 18 100       8476 next unless defined $v;
459 4         15 push @lines, "$name = $v\n";
460              
461             }
462 2         17 $logger->info("writing file ".$app_file);
463 2         33 $app_file->spew(@lines);
464             }
465              
466             }
467              
468             sub write_all {
469 4     4 1 1769587 my $self = shift ;
470 4         12 my %args = @_ ;
471 4         16 my $root_obj = $self->meta_root ;
472 4         22 my $dir = $self->model_dir ;
473              
474 4 50       16 croak "write_all: unexpected parameters ",join(' ', keys %args) if %args ;
475              
476 4         20 $self->write_app_files;
477              
478 4         1099 my $map = $self->{map} ;
479              
480 4         24 $dir->mkpath;
481              
482             # get list of all classes loaded by the editor
483             my %loaded_classes
484 4         233 = map { ($_ => 1); }
  65         416  
485             $root_obj->fetch_element('class')->fetch_all_indexes ;
486              
487             # remove classes that are listed in map
488 4         40 foreach my $file (keys %$map) {
489 20         25 foreach my $class_name (@{$map->{$file}}) {
  20         34  
490 40         66 delete $loaded_classes{$class_name} ;
491             }
492             }
493              
494             # add remaining classes in map
495             my %new_map = map {
496 4         20 my $f = $_;
  25         36  
497 25         54 $f =~ s!::!/!g;
498 25         76 ("$f.pl" => [ $_ ]) ;
499             } keys %loaded_classes ;
500              
501 4         27 my %map_to_write = (%$map,%new_map) ;
502              
503 4         18 foreach my $file (keys %map_to_write) {
504 45         10521 $logger->info("checking model file $file");
505              
506 45         397 my @data ;
507             my @notes ;
508 45         110 my $file_needs_write = 0;
509              
510             # check if any a class of a file was modified
511 45         94 foreach my $class_name (@{$map_to_write{$file}}) {
  45         183  
512 65 50       305 $file_needs_write++ if $self->class_needs_write($class_name);
513 65         1285 $logger->info("file $file class $class_name needs write ",$file_needs_write);
514             }
515              
516 45 50       364 next unless $file_needs_write ;
517              
518 45         92 foreach my $class_name (@{$map_to_write{$file}}) {
  45         108  
519 65         268 $logger->info("writing class $class_name");
520 65         564 my $model
521             = $self-> get_perl_data_model(class_name => $class_name) ;
522 65 50 33     541 push @data, $model if defined $model and keys %$model;
523              
524 65         481 my $node = $self->{meta_root}->grab("class:".$class_name) ;
525 65         22026 push @notes, $node->dump_annotations_as_pod ;
526             # remove class name from above list
527 65         3774565 delete $loaded_classes{$class_name} ;
528             }
529              
530 45 50       245 next unless @data ; # don't write empty model
531              
532 45         344 write_model_file ($dir->child($file), $self->{header}{$file}, \@notes, \@data);
533             }
534              
535 4         538 $self->meta_instance->clear_changes ;
536             }
537              
538             sub write_model_plugin {
539 2     2 1 2221 my $self = shift ;
540 2         11 my %args = @_ ;
541             my $plugin_dir = delete $args{plugin_dir}
542 2   33     9 || croak __PACKAGE__," write_model_plugin: undefined plugin_dir";
543             my $plugin_name = delete $args{plugin_name}
544 2   33     7 || croak __PACKAGE__," write_model_plugin: undefined plugin_name";
545 2 50       8 croak "write_model_plugin: unexpected parameters ",join(' ', keys %args) if %args ;
546              
547 2         28 my $model = $self->meta_root->dump_as_data(mode => 'custom') ;
548             # print (Dumper( $model)) ;
549              
550 2 50       1661221 my @raw_data = @{$model->{class} || []} ;
  2         14  
551 2         8 while (@raw_data) {
552 4         132 my ( $class , $data ) = splice @raw_data,0,2 ;
553 4         13 $data ->{name} = $class ;
554              
555             # does not distinguish between notes from underlying model or snipper notes ...
556 4         35 my @notes = $self->meta_root->grab("class:$class")->dump_annotations_as_pod ;
557 4         660973 my $plugin_file = $class.'.pl';
558 4         26 $plugin_file =~ s!::!/!g;
559 4         22 write_model_file ("$plugin_dir/$plugin_name/$plugin_file", [], \@notes, [ $data ]);
560             }
561              
562 2         107 $self->meta_instance->clear_changes ;
563             }
564              
565             sub read_model_plugin {
566 1     1 1 365 my $self = shift ;
567 1         5 my %args = @_ ;
568             my $plugin_dir = delete $args{plugin_dir}
569 1   33     4 || croak __PACKAGE__," write_model_plugin: undefined plugin_dir";
570             my $plugin_name = delete $args{plugin_name}
571 1   33     4 || croak __PACKAGE__," read_model_plugin: undefined plugin_name";
572              
573 1 50       3 croak "read_model_plugin: unexpected parameters ",join(' ', keys %args) if %args ;
574              
575 1         2 my @files ;
576             my $wanted = sub {
577 5     5   13 my $n = $File::Find::name ;
578 5 50 66     375 push @files, $n if (-f $_ and not /~$/
      66        
      33        
      33        
579             and $n !~ /CVS/
580             and $n !~ m!.(svn|orig|pod)$!
581             and $n =~ m!\.d/$plugin_name!
582             ) ;
583 1         8 } ;
584 1         66 find ($wanted, $plugin_dir ) ;
585              
586 1         10 my $class_element = $self->meta_root->fetch_element('class') ;
587              
588 1         66 foreach my $load_file (@files) {
589 2         341 $logger->info("trying to read plugin $load_file");
590              
591 2 50 33     42 $load_file = "./$load_file" if $load_file !~ m!^/! and -e $load_file;
592              
593 2         583 my $plugin = do $load_file ;
594              
595 2 50       10 unless ($plugin) {
596 0 0       0 if ($@) {die "couldn't parse $load_file: $@"; }
  0 0       0  
597 0         0 elsif (not defined $plugin) {die "couldn't do $load_file: $!"}
598 0         0 else { die "couldn't run $load_file" ;}
599             }
600              
601             # there should be only only class in each plugin file
602 2         5 foreach my $model (@$plugin) {
603 2         5 my $class_name = delete $model->{name} ;
604             # load with a array ref to avoid warnings about missing order
605 2         6 $class_element->fetch_with_id($class_name)->load_data( $model ) ;
606             }
607              
608             # load annotations
609 2         2476 $logger->info("loading annotations from plugin file $load_file");
610 2   50     19 my $fh = IO::File->new($load_file) || die "Can't open $load_file: $!" ;
611 2         163 my @lines = $fh->getlines ;
612 2         101 $fh->close;
613 2         31 $self->meta_root->load_pod_annotation(join('',@lines)) ;
614             }
615             }
616              
617              
618             #
619             # New subroutine "write_model_file" extracted - Mon Mar 12 13:38:29 2012.
620             #
621             sub write_model_file {
622 49     49 0 2755 my $wr_file = shift;
623 49         118 my $comments = shift ;
624 49         109 my $notes = shift;
625 49         110 my $data = shift;
626              
627 49         932 my $wr_dir = dirname($wr_file);
628 49 100       4354 unless ( -d $wr_dir ) {
629 8 50       1405 mkpath( $wr_dir, 0, 0755 ) || die "Can't mkpath $wr_dir:$!";
630             }
631              
632 49   33     520 my $wr = IO::File->new( $wr_file, '>' )
633             || croak "Cannot open file $wr_file:$!" ;
634 49         12381 $logger->info("in $wr_file");
635              
636 49         1140 my $dumper = Data::Dumper->new( [ \@$data ] );
637 49         2067 $dumper->Indent(1); # avoid too deep indentation
638 49         738 $dumper->Terse(1); # allow unnamed variables in dump
639 49         418 $dumper->Sortkeys(1); # sort keys in hash
640              
641 49         372 my $dump = $dumper->Dump;
642              
643             # munge pod text embedded in values to avoid spurious pod formatting
644 49         16725 $dump =~ s/\n=/\n'.'=/g;
645              
646 49         332 $wr->print(@$comments) ;
647 49         688 $wr->print( $dump, ";\n\n" );
648              
649 49         1297 $wr->print( join( "\n", @$notes ) );
650              
651 49         365 $wr->close;
652              
653             }
654              
655              
656              
657             sub list_class_element {
658 1     1 1 467 my $self = shift ;
659 1   50     8 my $pad = shift || '' ;
660              
661 1         2 my $res = '';
662 1         10 my $meta_class = $self->{meta_root}->fetch_element('class') ;
663 1         89 foreach my $class_name ($meta_class->fetch_all_indexes ) {
664 20         101 $res .= $self->list_one_class_element($class_name) ;
665             }
666 1         10 return $res ;
667             }
668              
669             sub list_one_class_element {
670 41     41 0 69 my $self = shift ;
671 41   50     98 my $class_name = shift || return '' ;
672 41   100     119 my $pad = shift || '' ;
673              
674 41         111 my $res = $pad."Class: $class_name\n";
675 41         134 my $meta_class = $self->{meta_root}->fetch_element('class')
676             -> fetch_with_id($class_name) ;
677              
678 41         3559 my @elts = $meta_class->fetch_element('element')->fetch_all_indexes ;
679              
680 41         3074 my @include = $meta_class->fetch_element('include')->fetch_all_values ;
681 41         60961 my $inc_after = $meta_class->grab_value('include_after') ;
682              
683 41 100 100     107563 if (@include and not defined $inc_after) {
684 10         32 map { $res .= $self->list_one_class_element($_,$pad.' ') ;} @include ;
  10         50  
685             }
686              
687 41 100       140 return $res unless @elts ;
688              
689 39         96 foreach my $elt_name ( @elts) {
690 393         1230 my $type = $meta_class->grab_value("element:$elt_name type") ;
691              
692 393         245586 $res .= $pad." - $elt_name ($type)\n";
693 393 100 100     1484 if (@include and defined $inc_after and $inc_after eq $elt_name) {
      100        
694 8         17 map { $res .=$self->list_one_class_element($_,$pad.' ') ;} @include ;
  11         49  
695             }
696             }
697 39         309 return $res ;
698             }
699              
700              
701             sub get_dot_diagram {
702 1     1 1 402 my $self = shift ;
703 1         3 my $dot = "digraph model {\n" ;
704              
705 1         7 my $meta_class = $self->{meta_root}->fetch_element('class') ;
706 1         76 foreach my $class_name ($meta_class->fetch_all_indexes ) {
707 20         93 my $d_class = $class_name ;
708 20         96 $d_class =~ s/::/__/g;
709              
710 20         52 my $elt_list = '';
711 20         37 my $use = '';
712              
713 20         143 my $class_obj = $self->{meta_root}->grab(qq!class:"$class_name"!);
714 20         7394 my @elts = $class_obj ->grab(qq!element!) ->fetch_all_indexes ;
715 20         6393 foreach my $elt_name ( @elts ) {
716 126         316 my $of = '';
717 126         823 my $elt_obj = $class_obj->grab(qq!element:"$elt_name"!) ;
718 126         46056 my $type = $elt_obj->grab_value("type") ;
719 126 100       61638 if ($type =~ /^list|hash$/) {
720 30         137 my $cargo = $elt_obj->grab("cargo");
721 30         8333 my $ct = $cargo->grab_value("type") ;
722 30         14952 $of = " of $ct" ;
723 30         140 $use .= $self->scan_used_class($d_class,$elt_name,$cargo);
724             }
725             else {
726 96         451 $use .= $self->scan_used_class($d_class,$elt_name,$elt_obj);
727             }
728 126         923 $elt_list .= "- $elt_name ($type$of)\\n";
729             }
730              
731 20         171 $dot .= $d_class
732             . qq! [shape=box label="$class_name\\n$elt_list"];\n!
733             . $use . "\n";
734              
735 20         87 $dot .= $self->scan_includes($class_name, $class_obj) ;
736             }
737              
738 1         5 $dot .="}\n";
739              
740 1         11 return $dot ;
741             }
742              
743             sub scan_includes {
744 20     20 0 77 my ($self,$class_name, $class_obj) = @_ ;
745 20         68 my $d_class = $class_name ;
746 20         129 $d_class =~ s/::/__/g;
747              
748 20         128 my @includes = $class_obj->grab('include')->fetch_all_values ;
749 20         56595 my $dot = '';
750 20         72 foreach my $c (@includes) {
751 13         551 say "$class_name includes $c";
752 13         47 my $t = $c;
753 13         82 $t =~ s/::/__/g;
754 13         62 $dot.= qq!$d_class -> $t ;\n!;
755             }
756 20         145 return $dot;
757             }
758              
759             sub scan_used_class {
760 126     126 0 527 my ($self,$d_class,$elt_name, $elt_obj) = @_ ;
761              
762             # define leaf call back
763             my $disp_leaf = sub {
764 2946     2946   20785116 my ($scanner, $data_ref, $node,$element_name,$index, $leaf_object) = @_ ;
765 2946 100       10757 return unless $element_name eq 'config_class_name';
766 28         117 my $v = $leaf_object->fetch;
767 28 100       67631 return unless $v;
768 21         151 $v =~ s/::/__/g;
769 21         255 $$data_ref .= qq!$d_class -> $v !
770             . qq![ style=dashed, label="$elt_name" ];\n!;
771 126         831 } ;
772              
773             # simple scanner, (print all values)
774 126         885 my $scan = Config::Model::ObjTreeScanner-> new (
775             leaf_cb => $disp_leaf, # only mandatory parameter
776             ) ;
777              
778 126         23673 my $result = '' ;
779 126         606 $scan->scan_node(\$result, $elt_obj) ;
780 126         69633 return $result ;
781             }
782              
783             __PACKAGE__->meta->make_immutable;
784              
785             1;
786              
787              
788             # ABSTRACT: Model editor for Config::Model
789              
790             __END__