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