Advanced-Config
view release on metacpan or search on metacpan
$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
$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 );
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 );
}
#######################################
# 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.
# 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.
$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] );
}
# 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 );
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
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.
}
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);
MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS
TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE
PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING,
REPAIR OR CORRECTION.
10. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING
WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR
REDISTRIBUTE THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES,
INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING
OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED
TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY
YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER
PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE
POSSIBILITY OF SUCH DAMAGES.
END OF TERMS AND CONDITIONS
Appendix: How to Apply These Terms to Your New Programs
If you develop a new program, and you want it to be of the greatest
possible use to humanity, the best way to achieve this is to make it
lib/Advanced/Config/Options.pm view on Meta::CPAN
}
# ==============================================================
=item $ref = apply_get_rules ( $tag, $section, $val1, $val2, $wide, $getOpts )
Returns an updated hash reference containing the requested data value after all
the I<$getOpts> rules have been applied. If the I<$tag> doesn't exist then it
will return B<undef> instead or B<die> if it's I<required>.
I<$val1> is the DATA hash value from the specified section.
I<$val2> is the DATA hash value from the parent section. This value is ignored
unless the I<inherit> option was specified via I<$getOpts>.
I<$wide> tells if UTF-8 dates are allowed.
=cut
# ==============================================================
sub apply_get_rules
{
DBUG_ENTER_FUNC (@_);
( run in 1.524 second using v1.01-cache-2.11-cpan-140bd7fdf52 )