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