Advanced-Config
view release on metacpan or search on metacpan
my $filename = shift;
my $read_opts = shift; # A hash ref of "read" options ...
my $get_opts = shift; # Another hash ref of "get" options ...
my $date_opts = shift; # Another hash ref of "date" formatting options ...
my $class = ref ( $prototype ) || $prototype;
my $self = {};
# Create an empty object ...
bless ( $self, $class );
# Creating a new object ... (The main section)
my %control;
# Initialize what options were selected ...
$control{filename} = $self->_fix_path ($filename);
$control{read_opts} = get_read_opts ( $read_opts );
$control{get_opts} = get_get_opts ( $get_opts );
$control{date_opts} = get_date_opts ( $date_opts );
my ( %dates, %empty, %mods, %ropts, %rec, @lst );
# Special Date Variables ...
set_special_date_vars ($control{date_opts}, \%dates);
$control{DATES} = \%dates;
$control{DATE_USED} = 0;
# Environment variables referenced ...
$control{ENV} = \%empty;
# Timestamps & options used for each config file loaded into memory ...
# Controls the refesh logic.
$control{REFRESH_MODIFY_TIME} = \%mods;
$control{REFRESH_READ_OPTIONS} = \%ropts;
# Used to detect recursion ...
$control{RECURSION} = \%rec;
# Used to detect recursion ...
$control{MERGE} = \@lst;
# The count for sensitive entries ...
$control{SENSITIVE_CNT} = sensitive_cnt ();
# Assume not allowing utf8/Unicode/Wide Char dates ...
# Or inside the config file itself.
$control{ALLOW_UTF8} = 0;
# Controls the behavior of this module.
# Only exists in the parent object.
$self->{CONTROL} = \%control;
my $key = $self->{SECTION_NAME} = DEFAULT_SECTION;
my %sections;
$sections{$key} = $self;
$self->{SECTIONS} = \%sections;
# Holds all the tag data for the main section in the config file.
my %data;
$self->{DATA} = \%data;
# Is the data all sensitive?
$self->{SENSITIVE_SECTION} = 0; # No for the default section ...
DBUG_RETURN ( $self );
}
# Only called by Advanced::Config::Reader::read_config() ...
# So not exposed in the POD!
# Didn't rely on read option 'use_utf8' since in many cases
# the option is misleading or just plain wrong!
sub _allow_utf8
{
DBUG_ENTER_FUNC ( @_ );
my $self = shift;
# Tells calls to Advanced::Config::Options::apply_get_rules() that
# it's ok to use Wide Char Languages like Greek.
my $pcfg = $self->{PARENT} || $self;
$pcfg->{CONTROL}->{ALLOW_UTF8} = 1;
DBUG_VOID_RETURN ();
}
# This private method preps for a clean refresh of the objects contents.
# Kept after the consructor so I can remember to add any new hashes to
# the list below.
sub _wipe_internal_data
{
DBUG_ENTER_FUNC ( @_ );
my $self = shift;
my $file = shift; # The main config file
# Wiping the main section automatically wipes everything else ...
$self = $self->{PARENT} || $self;
my ( %env, %mods, %rOpts, %rec, @lst, %sect, %data );
my $key = DEFAULT_SECTION;
$sect{$key} = $self;
$self->{CONTROL}->{filename} = $file;
$self->{CONTROL}->{ENV} = \%env;
$self->{CONTROL}->{REFRESH_MODIFY_TIME} = \%mods;
$self->{CONTROL}->{REFRESH_READ_OPTIONS} = \%rOpts;
$self->{CONTROL}->{RECURSION} = \%rec;
$self->{CONTROL}->{MERGE} = \@lst;
$self->{CONTROL}->{SENSITIVE_CNT} = sensitive_cnt ();
$self->{CONTROL}->{ALLOW_UTF8} = 0;
$self->{SECTIONS} = \%sect;
$self->{DATA} = \%data;
$self->{SENSITIVE_SECTION} = 0; # Not a sensitive section name!
DBUG_VOID_RETURN ();
}
#######################################
# =item $cfg = Advanced::Config->new_section ( $cfg_obj, $section );
# This special case constructor creates a new B<Advanced::Config> object and
# relates it to the given I<$cfg_obj> as a new section named I<$section>.
# It will call die if I<$cfg_obj> is not a valid B<Advanced::Config> object or
# the I<$section> is missing or already in use.
# Returns a reference to this new object.
# =cut
# Stopped exposing to public on 12/30/2019 ... but still used internally.
# In most cases 'create_section' should be called instead!
sub new_section
{
DBUG_ENTER_FUNC ( @_ );
my $prototype = shift;;
my $parent = shift;
my $section = shift;
my $class = ref ( $prototype ) || $prototype;
my $self = {};
# Create an empty object ...
bless ( $self, $class );
if ( ref ( $parent ) ne __PACKAGE__ ) {
die ("You must provide an ", __PACKAGE__, " object as an argument!\n");
}
# Make sure it's really the parent object ...
$parent = $parent->{PARENT} || $parent;
# Trim so we can check if unique ...
if ( $section ) {
$section =~ s/^\s+//; $section =~ s/\s+$//;
$section = lc ($section);
}
unless ( $section ) {
die ("You must provide a section name to use this constructor.\n");
}
# Creating a new section for the parent object ...
if ( exists $parent->{SECTIONS}->{$section} ) {
die ("Section \"${section}\" already exists!\n");
}
# Links the parent & child objects together ...
$parent->{SECTIONS}->{$section} = $self;
$self->{SECTION_NAME} = $section;
$self->{PARENT} = $parent;
# Holds all the tag data for this section in the config file.
my %data;
$self->{DATA} = \%data;
# Does this section have a sinsitive name?
# If so, all tags in this section are sensitive!
$self->{SENSITIVE_SECTION} = should_we_hide_sensitive_data ($section, 1);
DBUG_RETURN ( $self );
}
#######################################
=back
=head1 THE METHODS
Once you have your B<Advanced::Config> object initialized, you can manipulate
your object in many ways. You can access individual components of your config
file, modify its contents, refresh its contents and even organize it in
different ways.
Here are your exposed methods to help with this manipulation.
=head2 Loading the Config file into memory.
These methods are used to initialize the contents of an B<Advanced::Config>
object.
=over 4
=item $cfg = $cfg->load_config ( [$filename[, %override_read_opts]] );
This method reads the current I<$filename> into memory and converts it into an
object so that you may reference its contents. The I<$filename> must be defined
either here or in the call to B<new()>.
Each time you call this method, it wipes the contents of the object and starts
you from a clean slate again. Making it safe to call multiple times if needed.
The I<%override_read_opts> options apply just to the current call to
I<load_config> and will be forgotten afterwards. If you want these options
to persist between calls, set the option via the call to B<new()>. This
argument can be passed either by value or by reference. Either way will work.
See L<Advanced::Config::Options> for more details.
On success, it returns a reference to itself so that it can be initialized
separately or as a single unit.
Ex: $cfg = Advanced::Config->new(...)->load_config (...);
On failure it returns I<undef> or calls B<die> if option I<croak> is set!
WARNING: If basename(I<$filename>) is a symbolic link and your config file
contains encrypted data, please review the encryption options about special
considerations.
=cut
sub load_config
{
DBUG_ENTER_FUNC ( @_ );
my $self = shift;
if ( ref ( $m ) eq "SCALAR" ) {
$self->merge_string ( ${$m}, $opts->{$m} );
} else {
$self->merge_config ( $m, $opts->{$m} );
}
}
}
DBUG_RETURN ( $updated );
}
#######################################
# Private method ...
# Checks for recursion while sourcing in sub-files.
# Returns: 1 (yes) or 0 (no)
sub _recursion_check
{
DBUG_ENTER_FUNC (@_);
my $self = shift;
my $file = shift;
# Get the main/parent section to work against!
$self = $self->{PARENT} || $self;
DBUG_RETURN ( exists $self->{CONTROL}->{RECURSION}->{$file} ? 1 : 0 );
}
#######################################
# Private method ...
# Gets the requested tag from the current section.
# And then apply the required rules against the returned value.
# The {required} option isn't reliable until in this method!
# Returns: The tag hash ... (undef if it doesn't exist)
sub _base_get
{
my $self = shift;
my $tag = shift;
my $opts = shift;
my $disable_req = shift;
# Get the main/parent section to work against!
my $pcfg = $self->{PARENT} || $self;
# Determine what the "get" options must be ...
my $get_opts = $pcfg->{CONTROL}->{get_opts};
$get_opts = get_get_opts ( $opts, $get_opts ) if ( $opts );
# Check if a case insensitive lookup was requested ...
my $t = ( $pcfg->{CONTROL}->{read_opts}->{tag_case} && $tag ) ? lc ($tag) : $tag;
# Check if we're overriding the required flag ...
my $req = $get_opts->{required};
local $get_opts->{required} = $disable_req ? 0 : $req;
# Returns a hash reference to a local copy of the tag's data ... (or undef)
# Handles the inherit option if used.
my $data_ref =apply_get_rules ( $tag, $self->{SECTION_NAME},
$self->{DATA}->{$t}, $pcfg->{DATA}->{$t},
$pcfg->{CONTROL}->{ALLOW_UTF8},
$get_opts );
return ( wantarray ? ($data_ref, $req) : $data_ref );
}
# Private method ...
# Gets the requested tag value from the current section.
# Returns: All 5 of the hash members individually ... + required flag setting.
sub _base_get2
{
my $self = shift;
my $tag = shift;
my $opts = shift;
my ($data, $req) = $self->_base_get ( $tag, $opts, 0 );
if ( defined $data ) {
return ( $data->{VALUE}, $data->{MASK_IN_FISH}, $data->{FILE}, $data->{ENCRYPTED}, $data->{VARIABLE}, $req );
} else {
return ( undef, 0, "", 0, 0, $req ); # No such tag ...
}
}
# Private method ...
# Gets the requested tag date value from the current section.
# or treat the tag name as the date if the tag doesn't exist!
# Returns: All 5 of the hash members individually ... + required flag setting.
sub _base_get3_date_str
{
my $self = shift;
my $tag = shift;
my $opts = shift;
my $hyd_flg = shift; # Is it OK to return a HYD as HYD?
my $cvt_hyd_flg = shift; # Is it OK to convert a HYD into a date str?
if ($hyd_flg && $cvt_hyd_flg) {
local $opts->{required} = 1;
croak_helper ($opts, "Programming error! Can't set both hyd flags to true.", undef);
}
my ($data, $req);
{
local $opts->{date_active} = 0;
($data, $req) = $self->_base_get ( $tag, $opts, 1 ); # Does tag exist?
}
# If the tag doesn't exist, use $tag as a date string instead.
unless ( defined $data ) {
my $yr = _validate_date_str ($tag);
if ( defined $yr ) {
return ( $tag, 0, "", 0, 0, $req ); # We have a valid date string!
} elsif ( $hyd_flg && $tag =~ m/^[-]?\d+$/ ) {
return ( $tag, 0, "", 0, 0, $req ); # We have a valid HYD string!
} elsif ( $cvt_hyd_flg && $tag =~ m/^[-]?\d+$/ ) {
my $dt = convert_hyd_to_date_str ($tag);
return ( $dt, 0, "", 0, 0, $req ); # We have a valid date string!
} else {
#######################################
=item $array_ref = $cfg->get_list_directory ( $tag[, $access[, $pattern[, %override_get_opts]]] );
This is the list version of F<get_directory>. See that function for the meaning
of I<$access>. See F<get_list_values> for the meaning of I<$pattern>.
=cut
sub get_list_directory
{
DBUG_ENTER_FUNC ( @_ );
my $self = shift; # Reference to the current section.
my $tag = shift; # The tag to look up ...
my $access = shift; # undef or contains "r", "w" and/or "x" ...
my $split_ptrn = shift; # The split pattern to use to call to split().
my $opt_ref = $self->_get_opt_args ( @_ ); # The override options ...
# Tells us to split the tag's value up into an array ...
local $opt_ref->{split} = 1;
# Tells how to spit up the tag's value ...
local $opt_ref->{split_pattern} =
$self->_evaluate_hash_values ("split_pattern", $opt_ref, $split_ptrn);
my $value = $self->get_directory ( $tag, $access, $opt_ref );
DBUG_RETURN ( $value ); # An array ref or undef.
}
#######################################
# Private method ...
# Returns (Worked, Hide)
# Caller either wants both values or none of them.
# Should never write to fish ...
sub _base_set
{
my $self = shift;
my $tag = shift;
my $value = shift;
my $file = shift || ""; # The file the tag was defined in.
my $force_sensitive = shift || 0;
my $still_encrypted = shift || 0;
my $has_variables = shift || 0;
# Get the main/parent section to work against!
# my $pcfg = $self->get_section();
my $pcfg = $self->{PARENT} || $self;
# Check if case insensitive handling was requested ...
$tag = lc ($tag) if ( $pcfg->{CONTROL}->{read_opts}->{tag_case} );
if ( $tag =~ m/^shft3+$/i ) {
return ( 0, 0 ); # Set failed ... tag name not allowed.
}
my $hide = ($force_sensitive || $self->{SENSITIVE_SECTION}) ? 1 : 0;
if ( exists $self->{DATA}->{$tag} ) {
$hide = 1 if ( $self->{DATA}->{$tag}->{MASK_IN_FISH} );
} else {
my %data;
$self->{DATA}->{$tag} = \%data;
unless ( $hide ) {
$hide = 1 if ( should_we_hide_sensitive_data ($tag, 1) );
}
}
# The value must never be undefined!
$self->{DATA}->{$tag}->{VALUE} = (defined $value) ? $value : "";
# What file the tag was found in ...
$self->{DATA}->{$tag}->{FILE} = $file;
# Must it be hidden in the fish logs?
$self->{DATA}->{$tag}->{MASK_IN_FISH} = $hide;
# Is the value still encrypted?
$self->{DATA}->{$tag}->{ENCRYPTED} = $still_encrypted ? 1 : 0;
# Does the value still reference variables?
$self->{DATA}->{$tag}->{VARIABLE} = $has_variables ? 1 : 0;
return ( 1, $hide );
}
#######################################
=back
=head2 Manipulating the contents of an Advanced::Config object.
These methods allow you to manipulate the contents of an B<Advanced::Config>
object in many ways. They all just update what's in memory and not the contents
of the config file itself.
So should the contents of this module get refreshed, you will loose any changes
made by these B<4> methods.
=over
=item $ok = $cfg->set_value ( $tag, $value );
Adds the requested I<$tag> and it's I<$value> to the current section in the
I<Advanced::Config> object.
If the I<$tag> already exists, it will be overridden with its new I<$value>.
It returns B<1> on success or B<0> if your request was rejected!
It will also print a warning if it was rejected.
=cut
sub set_value
{
my $self = shift; # Reference to the current section of the object.
my $tag = shift; # The tag set to value ...
my $value = shift;
my ( $worked, $sensitive ) = $self->_base_set ($tag, $value, undef);
DBUG_MASK_NEXT_FUNC_CALL (2) if ( $sensitive );
DBUG_ENTER_FUNC ( $self, $tag, $value, @_ );
unless ( $worked ) {
warn ("You may not use \"${tag}\" as your tag name!\n");
}
DBUG_RETURN ($worked);
}
#######################################
=item $bool = $cfg->rename_tag ( $old_tag, $new_tag );
Renames the tag found in the current section to it's new name. If the
I<$new_tag> already exists it is overwriting by I<$old_tag>. If I<$old_tag>
doesn't exist the rename fails.
Returns B<1> on success, B<0> on failure.
=cut
sub rename_tag
{
DBUG_ENTER_FUNC (@_);
my $self = shift;
my $old_tag = shift;
my $new_tag = shift;
unless ( defined $old_tag && defined $new_tag ) {
warn ("All arguments to rename_tag() are required!\n");
return DBUG_RETURN (0);
}
if ( $new_tag =~ m/^shft3+$/i ) {
warn ("You may not use \"${new_tag}\" as your new tag name!\n");
return DBUG_RETURN (0);
}
# Get the main/parent section to work against!
my $pcfg = $self->{PARENT} || $self;
# Check if a case insensitive lookup was requested ...
if ( $pcfg->{CONTROL}->{read_opts}->{tag_case} ) {
$old_tag = lc ($old_tag) if ( $old_tag );
$new_tag = lc ($new_tag) if ( $new_tag );
}
if ( $old_tag eq $new_tag ) {
warn ("The new tag name must be different from the old tag name!\n");
return DBUG_RETURN (0);
}
# Was there something to rename ???
if ( exists $self->{DATA}->{$old_tag} ) {
$self->{DATA}->{$new_tag} = $self->{DATA}->{$old_tag};
delete ( $self->{DATA}->{$old_tag} );
return DBUG_RETURN (1);
}
DBUG_RETURN (0);
}
#######################################
=item $bool = $cfg->move_tag ( $tag, $new_section[, $new_tag] );
This function moves the tag from the current section to the specified new
section. If I<$new_tag> was provided that will be the tag's new name in
the new section. If the tag already exists in the new section it will be
overwritten.
If the tag or the new section doesn't exist, the move will fail! It will also
fail if the new section is the current section.
Returns B<1> on success, B<0> on failure.
=cut
sub move_tag
{
DBUG_ENTER_FUNC (@_);
my $self = shift;
my $tag = shift;
my $new_section = shift;
my $new_tag = shift;
$new_tag = $tag unless ( defined $new_tag );
unless ( defined $tag && defined $new_section ) {
warn ("Both \$tag and \$new_section are required for move_tag()!\n");
return DBUG_RETURN (0);
}
if ( $new_tag =~ m/^shft3+$/i ) {
warn ("You may not use \"${new_tag}\" as your new tag name!\n");
return DBUG_RETURN (0);
}
# Get the main/parent section to work against!
my $pcfg = $self->{PARENT} || $self;
# Check if a case insensitive lookup was requested ...
$tag = lc ($tag) if ( $pcfg->{CONTROL}->{read_opts}->{tag_case} && $tag );
my $cfg = $self->get_section ( $new_section ) || $self;
if ( $self ne $cfg && exists $self->{DATA}->{$tag} ) {
$cfg->{DATA}->{$new_tag} = $self->{DATA}->{$tag};
delete ( $self->{DATA}->{$tag} );
return DBUG_RETURN (1);
}
DBUG_RETURN (0);
}
#######################################
=item $bool = $cfg->delete_tag ( $tag );
This function removes the requested I<$tag> found in the current section from
the configuration data in memory.
Returns B<1> on success, B<0> if the I<$tag> didn't exist.
=cut
sub delete_tag
{
DBUG_ENTER_FUNC (@_);
my $self = shift;
my $tag = shift;
unless ( defined $tag ) {
return DBUG_RETURN (0); # Nothing to delete!
}
# Get the main/parent section to work against!
my $pcfg = $self->{PARENT} || $self;
# Check if a case insensitive lookup was requested ...
$tag = lc ($tag) if ( $pcfg->{CONTROL}->{read_opts}->{tag_case} && $tag );
# Was there something to delete ???
if ( exists $self->{DATA}->{$tag} ) {
delete ( $self->{DATA}->{$tag} );
return DBUG_RETURN (1);
}
DBUG_RETURN (0);
}
#######################################
=back
=head2 Breaking your Advanced::Config object into Sections.
Defining sections allow you to break up your configuration files into multiple
independent parts. Or in advanced configurations using sections to override
default values defined in the main/unlabled section.
=over
=item $section = $cfg->get_section ( [$section_name[, $required]] );
Returns the I<Advanced::Config> object for the requested section in your config
file. If the I<$section_name> doesn't exist, it will return I<undef>. If
I<$required> is set, it will call B<die> instead.
If no I<$section_name> was provided, it returns the default I<main> section.
=cut
sub get_section
{
DBUG_ENTER_FUNC ( @_ );
my $self = shift;
my $section = shift;
my $required = shift || 0;
$self = $self->{PARENT} || $self; # Force to parent section ...
unless ( defined $section ) {
$section = DEFAULT_SECTION;
} elsif ( $section =~ m/^\s*$/ ) {
$section = DEFAULT_SECTION;
} else {
$section = lc ($section);
$section =~ s/^\s+//;
$section =~ s/\s+$//;
}
if ( exists $self->{SECTIONS}->{$section} ) {
return DBUG_RETURN ( $self->{SECTIONS}->{$section} );
}
if ( $required ) {
die ("Section \"$section\" doesn't exist in this ", __PACKAGE__,
" class!\n");
}
DBUG_RETURN (undef);
}
#######################################
the parent object instead.
=cut
sub create_section
{
DBUG_ENTER_FUNC ( @_ );
my $self = shift;
my $name = shift;
# This test bypasses all the die logic in the special case constructor!
# That constructor is no longer exposed in the POD.
if ( $self->get_section ( $name ) ) {
return DBUG_RETURN (undef); # Name is already in use ...
}
DBUG_RETURN ( $self->new_section ( $self, $name ) );
}
#######################################
=back
=head2 Searching the contents of an Advanced::Config object.
This section deals with the methods available for searching for content within
your B<Advanced::Config> object.
=over
=item @list = $cfg->find_tags ( $pattern[, $override_inherit] );
It returns a list of all tags whose name contains the passed pattern.
If the pattern is B<undef> or the empty string, it will return all tags in
the current section. Otherwise it does a case insensitive comparison of the
pattern against each tag to see if it should be returned or not.
If I<override_inherit> is provided it overrides the current I<inherit> option's
setting. If B<undef> it uses the current I<inherit> setting. If I<inherit>
evaluates to true, it looks in the current section I<and> the main section for
a match. Otherwise it just looks in the current section.
The returned list of tags will be sorted in alphabetical order.
=cut
sub find_tags
{
DBUG_ENTER_FUNC (@_);
my $self = shift;
my $pattern = shift;
my $inherit = shift; # undef, 0, or 1.
my @lst; # The list of tags found ...
my $pcfg = $self->{PARENT} || $self;
$inherit = $pcfg->{CONTROL}->{get_opts}->{inherit} unless (defined $inherit);
foreach my $tag ( sort keys %{$self->{DATA}} ) {
unless ( $pattern ) {
push (@lst, $tag);
} elsif ( $tag =~ m/${pattern}/i ) {
push (@lst, $tag);
}
}
# Are we searching the parent/main section as well?
if ( $inherit && $pcfg != $self ) {
DBUG_PRINT ("INFO", "Also searching the 'main' section ...");
foreach my $tg ( sort keys %{$pcfg->{DATA}} ) {
# Ignore tags repeated from the current section
next if ( exists $self->{DATA}->{$tg} );
unless ( $pattern ) {
push (@lst, $tg);
} elsif ( $tg =~ m/$pattern/i ) {
push (@lst, $tg);
}
}
@lst = sort ( @lst ); # Sort the merged list.
}
DBUG_RETURN ( @lst );
}
#######################################
# No pod on purpose since exposing it would just cause confusion.
# It's a special case variant for find_tags().
# Just called from Advanced::Config::Reader::apply_modifier.
sub _find_variables
{
DBUG_ENTER_FUNC (@_);
my $self = shift;
my $pattern = shift;
my %res;
# Find all tags begining with the pattern ...
foreach ( $self->find_tags ("^${pattern}") ) {
$res{$_} = 1;
}
# Find all environment variables starting with the given pattern ...
foreach ( keys %ENV ) {
# Never include these 2 special tags in any list ...
next if ( defined $secret_tag && $secret_tag eq $_ );
next if ( defined $fish_tag && $fish_tag eq $_ );
$res{$_} = 4 if ( $_ =~ m/^${pattern}/ );
}
# Skip checking the Perl special variables we use (rule 5)
# Since it's now part of (rule 6)
# Check the pre-defined module variables ... (rule 6)
foreach ( keys %begin_special_vars ) {
$res{$_} = 6 if ( $_ =~ m/^${pattern}/ );
}
# The special date variables ... (rule 7)
my $pcfg = $self->{PARENT} || $self;
foreach ( keys %{$pcfg->{CONTROL}->{DATES}} ) {
$res{$_} = 7 if ( $_ =~ m/^${pattern}/ );
}
DBUG_RETURN ( sort keys %res );
}
#######################################
=item @list = $cfg->find_values ( $pattern[, $override_inherit] );
It returns a list of all tags whose values contains the passed pattern.
If the pattern is B<undef> or the empty string, it will return all tags in
the current section. Otherwise it does a case insensitive comparison of the
pattern against each tag's value to see if it should be returned or not.
If I<override_inherit> is provided it overrides the current I<inherit> option's
setting. If B<undef> it uses the current I<inherit> setting. If I<inherit>
evaluates to true, it looks in the current section I<and> the main section for
a match. Otherwise it just looks in the current section.
The returned list of tags will be sorted in alphabetical order.
=cut
sub find_values
{
DBUG_ENTER_FUNC (@_);
my $self = shift;
my $pattern = shift;
my $inherit = shift;
my @lst; # The list of tags found ...
my $pcfg = $self->{PARENT} || $self;
$inherit = $pcfg->{CONTROL}->{get_opts}->{inherit} unless (defined $inherit);
foreach my $tag ( sort keys %{$self->{DATA}} ) {
unless ( $pattern ) {
push (@lst, $tag);
} else {
my $value = $self->{DATA}->{$tag}->{VALUE};
if ( $value =~ m/$pattern/i ) {
push (@lst, $tag);
}
}
}
# Are we searching the parent/main section as well?
if ( $inherit && $pcfg != $self ) {
DBUG_PRINT ("INFO", "Also searching the main section ...");
foreach my $tg ( sort keys %{$pcfg->{DATA}} ) {
# Ignore tags repeated from the current section
next if ( exists $self->{DATA}->{$tg} );
unless ( $pattern ) {
push (@lst, $tg);
} else {
my $value = $pcfg->{DATA}->{$tg}->{VALUE};
if ( $value =~ m/$pattern/i ) {
push (@lst, $tg);
}
}
}
@lst = sort (@lst); # Sort the merged list.
}
DBUG_RETURN (@lst);
}
#######################################
=item @list = $cfg->find_sections ( $pattern );
It returns a list of all section names which match this pattern.
If the pattern is B<undef> or the empty string, it will return all the section
names. Otherwise it does a case insensitive comparison of the pattern against
each section name to see if it should be returned or not.
The returned list of section names will be sorted in alphabetical order.
=cut
sub find_sections
{
DBUG_ENTER_FUNC (@_);
my $self = shift;
my $pattern = shift;
$self = $self->{PARENT} || $self; # Force to parent section ...
my @lst;
foreach my $name ( sort keys %{$self->{SECTIONS}} ) {
unless ( $pattern ) {
push (@lst, $name);
} elsif ( $name =~ m/$pattern/i ) {
push (@lst, $name);
}
}
DBUG_RETURN (@lst);
}
#######################################
=back
=head2 Miscellaneous methods against Advanced::Config object.
These methods while useful don't really fall into a category of their own. So
they are collected here in the miscellaneous section.
=over
=item $file = $cfg->filename ( );
( run in 0.481 second using v1.01-cache-2.11-cpan-140bd7fdf52 )