File Coverage

blib/lib/Config/Model/AnyThing.pm
Criterion Covered Total %
statement 113 136 83.0
branch 46 66 69.7
condition 37 52 71.1
subroutine 24 29 82.7
pod 9 16 56.2
total 229 299 76.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             use Mouse;
12 59     59   29973  
  59         118  
  59         382  
13             # FIXME: must cleanup warp mechanism to implement this
14             # use MouseX::StrictConstructor;
15              
16             use Pod::POM;
17 59     59   45013 use Carp;
  59         1034181  
  59         2868  
18 59     59   432 use Log::Log4perl qw(get_logger :levels);
  59         132  
  59         2986  
19 59     59   355 use 5.10.1;
  59         129  
  59         502  
20 59     59   7076  
  59         184  
21             my $logger = get_logger("Anything");
22             my $change_logger = get_logger("ChangeTracker");
23              
24             has element_name => ( is => 'ro', isa => 'Str' );
25             has parent => ( is => 'ro', isa => 'Config::Model::Node', weak_ref => 1 );
26              
27             has instance => (
28             is => 'ro',
29             isa => 'Config::Model::Instance',
30             weak_ref => 1,
31             handles => [qw/show_message root_path/]
32             );
33              
34             # needs_check defaults to 1 to trap undef mandatory values
35             has needs_check => ( is => 'rw', isa => 'Bool', default => 1 );
36              
37             # index_value can be written to when move method is called. But let's
38             # not advertise this feature.
39             has index_value => (
40             is => 'rw',
41             isa => 'Str',
42             trigger => sub { my $self = shift; $self->{location} = $self->_location; },
43             );
44              
45             has container => ( is => 'ro', isa => 'Ref', required => 1, weak_ref => 1 );
46              
47             has container_type => ( is => 'ro', isa => 'Str', builder => '_container_type', lazy => 1 );
48              
49             my $self = shift;
50             my $p = $self->parent;
51 0     0   0 return defined $p
52 0         0 ? $p->element_type( $self->element_name )
53 0 0       0 : 'node'; # root node
54              
55             }
56              
57             has root => (
58             is => 'ro',
59             isa => 'Config::Model::Node',
60             weak_ref => 1,
61             builder => '_root',
62             lazy => 1
63             );
64              
65             my $self = shift;
66              
67             return $self->parent || $self;
68 15     15   36 }
69              
70 15   66     160 has location => ( is => 'ro', isa => 'Str', builder => '_location', lazy => 1 );
71             has location_short => ( is => 'ro', isa => 'Str', builder => '_location_short', lazy => 1 );
72              
73             has backend_support_annotation => (
74             is => 'ro',
75             isa => 'Bool',
76             builder => '_backend_support_annotation',
77             lazy => 1
78             );
79              
80             my $self = shift;
81             # this method is overridden in Config::Model::Node
82             return $self->parent->backend_support_annotation;
83             };
84 1     1   3  
85             my $self = shift;
86 1         8 my %args = @_;
87              
88             return if $self->instance->initial_load and not $args{really};
89              
90 4088     4088 1 5629 if ($change_logger->is_trace) {
91 4088         14190 my @with = map { "'$_' -> '". ($args{$_} // '<undef>') ."'" } sort keys %args;
92             $change_logger->trace("called for ", $self->name, " from ", join( ' ', caller ), " with ", join( ' ', @with ));
93 4088 50 66     12492 }
94              
95 4088 100       8024 # needs_save may be overridden by caller
96 224   100     1139 $args{needs_save} //= 1;
  1314         3482  
97 224         578 $args{path} //= $self->location;
98             $args{name} //= $self->element_name if $self->element_name;
99             $args{index} //= $self->index_value if $self->index_value;
100              
101 4088   100     27234 # better use %args instead of @_ to forward arguments. %args eliminates duplicated keys
102 4088   100     11447 $self->container->notify_change(%args);
103 4088 100 66     15275 }
104 4088 100 66     11589  
105             my $self = shift;
106              
107 4088         18525 my $str = '';
108             $str .= $self->parent->location if defined $self->parent;
109              
110             $str .= ' ' if $str;
111 3317     3317   6861  
112             $str .= $self->composite_name;
113 3317         5118  
114 3317 100       15711 return $str;
115             }
116 3317 100       7250  
117             my $self = shift;
118 3317         8135  
119             my $str = '';
120 3317         17926 $str .= $self->parent->location_short if defined $self->parent;
121              
122             $str .= ' ' if $str;
123              
124 51     51   97 $str .= $self->composite_name_short;
125              
126 51         78 return $str;
127 51 100       301 }
128              
129 51 100       109 #has composite_name => (is => 'ro', isa => 'Str' , builder => '_composite_name', lazy => 1);
130              
131 51         137 my $self = shift;
132              
133 51         251 my $element = $self->element_name;
134             $element = '' unless defined $element;
135              
136             my $idx = $self->index_value;
137             return $element unless defined $idx;
138             $idx = '"' . $idx . '"' if $idx =~ /\W/;
139 3535     3535 1 5875  
140             return "$element:$idx";
141 3535         7909 }
142 3535 100       7246  
143             my $self = shift;
144 3535         7720  
145 3535 100       8452 my $element = $self->element_name;
146 1199 100       3945 $element = '' unless defined $element;
147              
148 1199         3273  
149             my $idx = $self->shorten_idx($self->index_value);
150             return $element unless length $idx;
151             $idx = '"' . $idx . '"' if $idx =~ /\W/;
152 51     51 1 71 return "$element:$idx";
153             }
154 51         110  
155 51 100       111 my $self = shift;
156             my $long_index = shift ;
157              
158 51         172 my @idx = split /\n/, $long_index // '' ;
159 51 100       173 my $idx = shift @idx;
160 1 50       6 $idx .= '[...]' if @idx;
161 1         5  
162             return $idx // ''; # may be undef on freebsd with perl 5.10.1 ...
163             }
164              
165 58     58 0 96  
166 58         79 ## Fixme: not yet tested
167             my $self = shift;
168 58   100     222  
169 58         94 $logger->trace("xpath called on $self");
170 58 100       116  
171             my $element = $self->element_name;
172 58   100     241 $element = '' unless defined $element;
173              
174             my $idx = $self->index_value;
175              
176             my $str = '';
177             $str .= $self->cim_parent->parent->xpath
178 0     0 0 0 if $self->can('cim_parent')
179             and defined $self->cim_parent;
180 0         0  
181             $str .= '/' . $element . ( defined $idx ? "[\@id=$idx]" : '' ) if $element;
182 0         0  
183 0 0       0 return $str;
184             }
185 0         0  
186             my $self = shift;
187 0         0 my $old_note = $self->{annotation} || '';
188 0 0 0     0 if (@_ and not $self->instance->preset and not $self->instance->layered) {
189             my $new = $self->{annotation} = join( "\n", grep { defined $_} @_ );
190             $self->notify_change(note => 'updated annotation') unless $new eq $old_note;
191             }
192 0 0       0  
    0          
193             return $self->{annotation} || '';
194 0         0 }
195              
196             my $self = shift;
197             $self->notify_change(note => 'deleted annotation') if $self->{annotation};
198 6783     6783 1 9966 $self->{annotation} = '';
199 6783   100     18833 }
200 6783 100 66     14586  
      100        
201 201         456 # may be used (but not yet) to load annotation from perl data file
  214         839  
202 201 100       816 my $self = shift;
203             my $pod = shift;
204              
205 6783   100     23106 my $parser = Pod::POM->new();
206             my $pom = $parser->parse_text($pod)
207             || croak $parser->error();
208             my $sections = $pom->head1();
209 1     1 1 3  
210 1 50       10 foreach my $s (@$sections) {
211 1         7 next unless $s->title eq 'Annotations';
212              
213             foreach my $item ( $s->over->[0]->item ) {
214             my $path = $item->title . ''; # force string representation. Not understood why...
215             $path =~ s/^[\s\*]+//;
216 1     1 1 4507 my $note = $item->text . '';
217 1         2 $note =~ s/\s+$//;
218             $logger->trace("load_pod_annotation: '$path' -> '$note'");
219 1         13 $self->grab( steps => $path )->annotation($note);
220 1   33     20 }
221             }
222 1         3464 }
223              
224 1         22 # fallback method for object that don't implement has_data
225 1 50       6 my $self= shift;
226             $logger->trace("called fall-back has_data for element", $self->name) if $logger->is_trace;
227 1         120 return 1;
228 9         78 }
229 9         444  
230 9         33 my $self = shift;
231 9         608 my %args = @_;
232 9         38  
233 9         77 my $model = $self->instance->config_model;
234             return Config::Model::SearchElement->new( model => $model, node => $self, %args );
235             }
236              
237             carp "Config::Model::AnyThing searcher is deprecated";
238             goto &model_searcher;
239             }
240 0     0 0 0  
241 0 0       0 my $self = shift;
242 0         0 my %args = @_;
243             my $full = delete $args{full_dump} || 0;
244             if ($full) {
245             carp "dump_as_data: full_dump parameter is deprecated. Please use 'mode => user' instead";
246 8     8 1 751 $args{mode} //= 'user';
247 8         17 }
248             my $dumper = Config::Model::DumpAsData->new;
249 8         30 $dumper->dump_as_data( node => $self, %args );
250 8         40 }
251              
252             # hum, check if the check information is valid
253             my $self = shift;
254 0     0 0 0 my $p = shift;
255 0         0  
256             return 'yes' if not defined $p or $p eq '1' or $p eq 'yes';
257             return 'no' if $p eq '0' or $p eq 'no';
258             return $p if $p eq 'skip';
259 41     41 1 16584  
260 41         137 croak "Internal error: Unvalid check value: $p";
261 41   50     155 }
262 41 50       92  
263 0         0 my $self = shift;
264 0   0     0 $logger->trace( "dummy has_fixes called on " . $self->name );
265             return 0;
266 41         197 }
267 41         140  
268             my $self = shift;
269             $logger->trace( "dummy has_warning called on " . $self->name );
270             return 0;
271             }
272 39728     39728   55061  
273 39728         53551 my $self = shift;
274             return '' unless defined $self->{warper};
275 39728 100 66     150158 return $self->{warper}->warp_error;
      100        
276 7059 100 66     21389 }
277 5387 50       14102  
278             # used by Value and AnyId
279 0         0 my ( $self, $arg_ref ) = @_;
280              
281             my $convert = delete $arg_ref->{convert};
282              
283 0     0 0 0 # convert_sub keeps a subroutine reference
284 0         0 $self->{convert_sub} =
285 0         0 $convert eq 'uc' ? sub { uc(shift) }
286             : $convert eq 'lc' ? sub { lc(shift) }
287             : undef;
288              
289 4     4 0 8 Config::Model::Exception::Model->throw(
290 4         21 object => $self,
291 4         40 error => "Unexpected convert value: $convert, " . "expected lc or uc"
292             ) unless defined $self->{convert_sub};
293             }
294              
295 16     16 1 33 __PACKAGE__->meta->make_immutable;
296 16 100       63  
297 7         28 1;
298              
299             # ABSTRACT: Base class for configuration tree item
300              
301              
302 54     54 0 99 =pod
303              
304 54         119 =encoding UTF-8
305              
306             =head1 NAME
307              
308 2     2   9 Config::Model::AnyThing - Base class for configuration tree item
309 101     101   273  
310 54 50       294 =head1 VERSION
    100          
311              
312             version 2.152
313              
314             =head1 SYNOPSIS
315 54 50       227  
316             # internal class
317              
318             =head1 DESCRIPTION
319              
320             This class must be inherited by all nodes or leaves of the
321             configuration tree.
322              
323             AnyThing provides some methods and no constructor.
324              
325             =head1 Introspection methods
326              
327             =head2 element_name
328              
329             Returns the element name that contain this object.
330              
331             =head2 index_value
332              
333             For object stored in an array or hash element, returns the index (or key)
334             containing this object.
335              
336             =head2 parent
337              
338             Returns the node containing this object. May return undef if C<parent>
339             is called on the root of the tree.
340              
341             =head2 container
342              
343             A bit like parent, this method returns the element containing this
344             object. See L</container_type>
345              
346             =head2 container_type
347              
348             Returns the type (e.g. C<list> or C<hash> or C<leaf> or C<node> or
349             C<warped_node>) of the element containing this object.
350              
351             =head2 root
352              
353             Returns the root node of the configuration tree.
354              
355             =head2 location
356              
357             Returns the node location in the configuration tree. This location
358             conforms with the syntax defined by L<grab|Config::Model::Role::Grab/grab> method.
359              
360             =head2 location_short
361              
362             Returns the node location in the configuration tree. This location truncates long
363             indexes to be readable. It cannot be used by L<grab|Config::Model::Role::Grab/grab> method.
364              
365             =head2 composite_name
366              
367             Return the element name with its index (if any). I.e. returns C<foo:bar> or
368             C<foo>.
369              
370             =head2 composite_name_short
371              
372             Return the element name with its index (if any). Too long indexes are
373             truncated to be readable.
374              
375             =head1 Annotation
376              
377             Annotation is a way to store miscellaneous information associated to
378             each node. (Yeah... comments). Reading and writing annotation makes
379             sense only if they can be read from and written to the configuration
380             file, hence the need for the following method:
381              
382             =head2 backend_support_annotation
383              
384             Returns 1 if at least one of the backends attached to a parent node
385             support to read and write annotations (aka comments) in the
386             configuration file.
387              
388             =head2 support_annotation
389              
390             Returns 1 if at least one of the backends support to read and write annotations
391             (aka comments) in the configuration file.
392              
393             =head2 annotation
394              
395             Parameters: C<( [ note1, [ note2 , ... ] ] )>
396              
397             Without argument, return a string containing the object's annotation (or
398             an empty string).
399              
400             With several arguments, join the arguments with "\n", store the annotations
401             and return the resulting string.
402              
403             =head2 load_pod_annotation
404              
405             Parameters: C<( pod_string )>
406              
407             Load annotations in configuration tree from a pod document. The pod must
408             be in the form:
409              
410             =over
411            
412             =item path
413            
414             Annotation text
415            
416             =back
417              
418             =head2 clear_annotation
419              
420             Clear the annotation of an element
421              
422             =head1 Information management
423              
424             =head2 notify_change
425              
426             Notify the instance of semantic changes. Parameters are:
427              
428             =over 8
429              
430             =item old
431              
432             old value. (optional)
433              
434             =item new
435              
436             new value (optional)
437              
438             =item path
439              
440             Location of the changed parameter starting from root node. Default to C<$self->location>.
441              
442             =item name
443              
444             element name. Default to C<$self->element_name>
445              
446             =item index
447              
448             If the changed parameter is part of a hash or an array, C<index>
449             contains the key or the index to get the changed parameter.
450              
451             =item note
452              
453             information about the change. Mandatory when neither old or new value are defined.
454              
455             =item really
456              
457             When set to 1, force recording of change even if in initial load phase.
458              
459             =item needs_save
460              
461             internal parameter.
462              
463             =back
464              
465             =head2 show_message
466              
467             Parameters: C<( string )>
468              
469             Forwarded to L<Config::Model::Instance/show_message>.
470              
471             =head2 root_path
472              
473             Forwarded to L<Config::Model::Instance/"root_path">.
474              
475             =head2 model_searcher
476              
477             Returns an object dedicated to search an element in the configuration
478             model.
479              
480             This method returns a L<Config::Model::SearchElement> object. See
481             L<Config::Model::Searcher> for details on how to handle a search.
482              
483             =head2 dump_as_data
484              
485             Dumps the configuration data of the node and its siblings into a perl
486             data structure.
487              
488             Returns a hash ref containing the data. See
489             L<Config::Model::DumpAsData> for details.
490              
491             =head2 warp_error
492              
493             Returns a string describing any issue with L<Config::Model::Warper> object.
494             Returns '' if invoked on a tree object without warp specification.
495              
496             =head1 AUTHOR
497              
498             Dominique Dumont, (ddumont at cpan dot org)
499              
500             =head1 SEE ALSO
501              
502             L<Config::Model>,
503             L<Config::Model::Instance>,
504             L<Config::Model::Node>,
505             L<Config::Model::Loader>,
506             L<Config::Model::Dumper>
507              
508             =head1 AUTHOR
509              
510             Dominique Dumont
511              
512             =head1 COPYRIGHT AND LICENSE
513              
514             This software is Copyright (c) 2005-2022 by Dominique Dumont.
515              
516             This is free software, licensed under:
517              
518             The GNU Lesser General Public License, Version 2.1, February 1999
519              
520             =cut