File Coverage

blib/lib/Config/Model/Describe.pm
Criterion Covered Total %
statement 119 120 99.1
branch 43 48 89.5
condition 24 32 75.0
subroutine 16 16 100.0
pod 2 2 100.0
total 204 218 93.5


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             package Config::Model::Describe 2.153; # TRIAL
12              
13 59     59   445 use Carp;
  59         177  
  59         3477  
14 59     59   440 use strict;
  59         205  
  59         1339  
15 59     59   363 use warnings;
  59         154  
  59         1837  
16              
17 59     59   386 use Config::Model::Exception;
  59         177  
  59         1821  
18 59     59   435 use Config::Model::ObjTreeScanner;
  59         179  
  59         2004  
19 59     59   418 use List::Util qw/max/;
  59         185  
  59         4870  
20 59     59   36933 use utf8;
  59         930  
  59         444  
21              
22             sub new {
23 9     9 1 27 bless {}, shift;
24             }
25              
26             sub describe {
27 9     9 1 16 my $self = shift;
28              
29 9         30 my %args = @_;
30             my $desc_node = delete $args{node}
31 9   33     30 || croak "describe: missing 'node' parameter";
32 9   100     34 my $check = delete $args{check} || 'yes';
33              
34 9         17 my $element = delete $args{element} ; # optional
35 9         16 my $pattern = delete $args{pattern} ; # optional
36 9   100     31 my $hide_empty = delete $args{hide_empty} // 0 ; # optional
37 9   100     26 my $verbose = delete $args{verbose} // 0 ; # optional
38              
39 9         30 my $show_empty = ! $hide_empty ;
40              
41             my $tag_name = sub {
42 66 100   66   191 $_[1] .= ' ⚠' if $_[0]->has_warning;
43 9         35 };
44              
45             my $my_content_cb = sub {
46 8     8   35 my ( $scanner, $data_ref, $node, @element ) = @_;
47             # filter elements according to pattern
48 8 100       31 my @scan = $pattern ? grep { $_ =~ $pattern } @element : @element;
  56         149  
49 8         27 for (@scan) { $scanner->scan_element( $data_ref, $node, $_ ) }
  68         205  
50 9         37 };
51              
52             my $std_cb = sub {
53 39     39   89 my ( $scanner, $data_r, $obj, $element, $index, $value_obj ) = @_;
54              
55 39         116 my $value = $value_obj->fetch( check => $check, mode => 'user' );
56              
57 39 100 66     156 return unless $show_empty or (defined $value and length($value));
      66        
58              
59 34 100 100     119 $value = substr($value,0,12).'[…]' if $value and length($value) > 12;
60              
61 34 100 100     179 $value = '"' . $value . '"' if defined $value and $value =~ /\s/;
62              
63 34 100       91 my $name = defined $index ? "$element:$index" : $element;
64 34 100       70 $value = defined $value ? $value : '[undef]';
65              
66 34         82 my $type = $value_obj->value_type;
67 34         51 my @comment;
68 34 100       82 if (my $default = $value_obj->fetch(mode => 'standard')) {
69 18 100       80 my $defstr = $type =~ /uniline|string/ ? qq!"$default"! : $default;
70 18         51 push @comment, "default: $defstr";
71             }
72 34 100       74 push @comment, "choice: " . join( ' ', @{ $value_obj->choice } )
  6         29  
73             if $type eq 'enum';
74 34 100       114 push @comment, 'mandatory' if $value_obj->mandatory;
75              
76 34         96 $tag_name->($value_obj,$element);
77 34         404 push @$data_r, [ $name, $type, $value, join( ', ', @comment ) ];
78 9         40 };
79              
80             my $list_element_cb = sub {
81 12     12   42 my ( $scanner, $data_r, $obj, $element, @keys ) = @_;
82              
83             #print "DEBUG: list_element_cb on $element, keys @keys\n";
84 12         26 my $list_obj = $obj->fetch_element($element);
85 12         54 my $elt_type = $list_obj->cargo_type;
86              
87 12         39 $tag_name->($list_obj,$element);
88 12 100       27 if ( $elt_type eq 'node' ) {
89 3         16 my $class_name = $list_obj->config_class_name;
90 3 50       10 my @show_keys = @keys ? @keys : ('<empty>');
91 3         25 push @$data_r, [ $element, "<$class_name>", 'node list', "indexes: @show_keys" ];
92             }
93             else {
94 9 100       38 my @values = grep { $show_empty or length } $list_obj->fetch_all_values( check => 'no' ) ;
  21         62  
95 9 100 100     81 push @$data_r,
96             [ $element, 'list', join( ',', @values ), '' ] if ($show_empty or @values);
97             }
98 9         39 };
99              
100             my $check_list_element_cb = sub {
101 3     3   14 my ( $scanner, $data_r, $obj, $element, @choices ) = @_;
102              
103 3         8 my $list_obj = $obj->fetch_element($element);
104 3         10 $tag_name->($list_obj,$element);
105 3         10 my @checked = $list_obj->get_checked_list;
106 3 50 66     29 push @$data_r, [ $element, 'check_list', join( ',', @checked ), '' ] if $show_empty or @checked;
107 9         32 };
108              
109             my $hash_element_cb = sub {
110 17     17   45 my ( $scanner, $data_r, $obj, $element, @keys ) = @_;
111              
112             #print "DEBUG: hash_element_cb on $element, keys @keys\n";
113 17         42 my $hash_obj = $obj->fetch_element($element);
114 17         50 my $elt_type = $hash_obj->cargo_type;
115              
116 17         67 $tag_name->($hash_obj,$element);
117 17 100       51 if ( $elt_type eq 'node' ) {
    100          
118 4         14 my $class_name = $hash_obj->config_class_name;
119 4 50       13 my @show_keys = @keys ? map { qq("$_") } @keys : ('<empty>');
  8         23  
120 4         16 my $show_str = "keys: @show_keys";
121 4         35 push @$data_r, [ $element, 'node hash', "<$class_name>", $show_str ];
122             }
123             elsif (@keys) {
124 4         8 for ( @keys ) { $scanner->scan_hash( $data_r, $obj, $element, $_ ) }
  8         25  
125             }
126             else {
127 9 100       49 push @$data_r, [ $element, 'value hash', "[empty hash]", "" ] if $show_empty;
128             }
129 9         35 };
130              
131             my $node_element_cb = sub {
132 6     6   14 my ( $scanner, $data_r, $obj, $element, $key, $next ) = @_;
133              
134             #print "DEBUG: elt_cb on $element, key $key\n";
135 6         13 my $type = $obj->element_type($element);
136              
137 6         15 my $class_name = $next->config_class_name;
138 6         41 push @$data_r, [ $element, 'node', "<$class_name>", $obj->gist ];
139              
140             #$ret .= ":$key" if $type eq 'list' or $type eq 'hash';
141              
142             #$view_scanner->scan_node($next);
143 9         28 };
144              
145 9         35 my @scan_args = (
146             fallback => 'all',
147             auto_vivify => 0,
148             list_element_cb => $list_element_cb,
149             check_list_element_cb => $check_list_element_cb,
150             hash_element_cb => $hash_element_cb,
151             leaf_cb => $std_cb,
152             node_element_cb => $node_element_cb,
153             node_content_cb => $my_content_cb,
154             );
155              
156 9         22 my @left = keys %args;
157 9 50       27 croak "Describe: unknown parameter:@left" if @left;
158              
159             # perform the scan
160 9         46 my $view_scanner = Config::Model::ObjTreeScanner->new(@scan_args);
161              
162 9         18 my @ret;
163 9 100 66     49 if ( defined $element and $desc_node->has_element($element) ) {
    50          
164 1         6 $view_scanner->scan_element( \@ret, $desc_node, $element );
165             }
166             elsif ( defined $element ) {
167 0   0     0 Config::Model::Exception::UnknownElement->throw(
168             object => $desc_node,
169             function => 'Describe',
170             where => $desc_node->location || 'configuration root',
171             element => $element,
172             );
173             }
174             else {
175 8         29 $view_scanner->scan_node( \@ret, $desc_node );
176             }
177              
178 9         27 my @header = qw/name type value/;
179 9         21 my $name_length = max map { length($_->[0]) } (@ret, \@header );
  71         132  
180 9         20 my $type_length = max map { length($_->[1]) } (@ret, \@header );
  71         106  
181 9         21 my $value_length = max map { length($_->[2]) } (@ret, \@header );
  71         106  
182 9         37 my $sep_length = $name_length + $type_length + $value_length + 4 ;
183 9         40 my @format = ("%-${name_length}s", "%-${type_length}s", "%-${value_length}s") ;
184              
185 9         16 my @show ;
186 9 100       21 if ($verbose) {
187 6         12 push @format, "%-35s";
188             @show = (
189             sprintf( join(" │ ", @format)."\n", qw/name type value comment/) ,
190             sprintf( join("─┼─", @format)."\n", '─' x $name_length,'─' x $type_length,'─' x $value_length,'─' x 20, ) ,
191 6         88 map { sprintf( join(" │ ", @format)."\n", @$_ ) } @ret
  25         133  
192             );
193             }
194             else {
195             @show = (
196             sprintf( join(" │ ", @format)."\n", qw/name type value/) ,
197             sprintf( join("─┼─", @format)."\n", '─' x $name_length,'─' x $type_length,'─' x $value_length ) ,
198 3         49 map { sprintf( join(" │ ", @format)."\n", @$_[0,1,2] ) } @ret
  37         165  
199             );
200             }
201              
202 9         424 return join ('', @show );
203             }
204              
205             1;
206              
207             # ABSTRACT: Provide a description of a node element
208              
209             __END__
210              
211             =pod
212              
213             =encoding UTF-8
214              
215             =head1 NAME
216              
217             Config::Model::Describe - Provide a description of a node element
218              
219             =head1 VERSION
220              
221             version 2.153
222              
223             =head1 SYNOPSIS
224              
225             use Config::Model;
226              
227             # define configuration tree object
228             my $model = Config::Model->new;
229             $model->create_config_class(
230             name => "Foo",
231             element => [
232             [qw/foo bar/] => {
233             type => 'leaf',
234             value_type => 'string'
235             },
236             ]
237             );
238             $model ->create_config_class (
239             name => "MyClass",
240              
241             element => [
242              
243             [qw/foo bar/] => {
244             type => 'leaf',
245             value_type => 'string'
246             },
247             hash_of_nodes => {
248             type => 'hash', # hash id
249             index_type => 'string',
250             cargo => {
251             type => 'node',
252             config_class_name => 'Foo'
253             },
254             },
255             ],
256             ) ;
257              
258             my $inst = $model->instance(root_class_name => 'MyClass' );
259              
260             my $root = $inst->config_root ;
261              
262             # put data
263             my $steps = 'foo=FOO hash_of_nodes:fr foo=bonjour -
264             hash_of_nodes:en foo=hello ';
265             $root->load( steps => $steps );
266              
267             print $root->describe ;
268              
269             ### prints
270             # name type value comment
271             # foo string FOO
272             # bar string [undef]
273             # hash_of_nodes node hash <Foo> keys: "en" "fr"
274              
275             =head1 DESCRIPTION
276              
277             This module is used directly by L<Config::Model::Node> to describe
278             a node element. This module returns a human readable string that
279             shows the content of a configuration node.
280              
281             For instance (as shown by C<fstab> example:
282              
283             name type value comment
284             fs_spec string [undef] mandatory
285             fs_vfstype enum [undef] choice: auto davfs ext2 ext3 swap proc iso9660 vfat ignore, mandatory
286             fs_file string [undef] mandatory
287             fs_freq boolean 0
288             fs_passno integer 0
289              
290             This module is also used by the C<ll> command of L<Config::Model::TermUI>.
291              
292             =head1 CONSTRUCTOR
293              
294             =head2 new
295              
296             No parameter. The constructor should be used only by
297             L<Config::Model::Node>.
298              
299             =head1 Methods
300              
301             =head2 describe
302              
303             Return a description string.
304              
305             Parameters are:
306              
307             =over
308              
309             =item node
310              
311             Reference to a L<Config::Model::Node> object. Mandatory
312              
313             =item element
314              
315             Describe only this element from the node. Optional. All elements are
316             described if omitted.
317              
318             =item pattern
319              
320             Describe the element matching the regexp ref. Example:
321              
322             describe => ( pattern => qr/^foo/ )
323              
324             =item hide_empty
325              
326             Boolean. Whether to hide empty value (i.e. C<undef> or C<''>) or not. Default is false.
327              
328             =item verbose
329              
330             Boolean. Display more information with each element. Default is false.
331              
332             =back
333              
334             =head1 AUTHOR
335              
336             Dominique Dumont, (ddumont at cpan dot org)
337              
338             =head1 SEE ALSO
339              
340             L<Config::Model>,L<Config::Model::Node>,L<Config::Model::ObjTreeScanner>
341              
342             =head1 AUTHOR
343              
344             Dominique Dumont
345              
346             =head1 COPYRIGHT AND LICENSE
347              
348             This software is Copyright (c) 2005-2022 by Dominique Dumont.
349              
350             This is free software, licensed under:
351              
352             The GNU Lesser General Public License, Version 2.1, February 1999
353              
354             =cut