Advanced-Config
view release on metacpan or search on metacpan
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 $ruleCfg = Advanced::Config->newDefineConfigRules ( $filename );
This special case constructor creates a new B<Advanced::Config> object, loads
it into memory and validates the resulting config file meets the requirements
for using this method and calls B<die> on any unexpected issues.
The resulting I<$ruleCfg> object is used to replace the 3 B<opts> hashes in the
call to I<new()>, so that all your programs don't have to be modified whenever a
vendor modifies how to parse their config files. You just need to modify this
configutation file and all your programs using it are updated all at once.
Example:
my $ruleCfg = Advanced::Config->newDefineConfigRules ( "VendorRules.cfg" );
my $cfg = Advanced::Config->new ( "vendor.cfg" )->
set_config_rules ($ruleCfg)->load_config ();
The B<VendorRules.cfg> assumes that any options not defined in this config file
defaults to the module's settings in L<Advanced::Config::Options>. So you only
need to enter your overrides. Meaning an empty config file just uses the
default rules. Any tag that doesn't match one of the option hash values is a
fatal error.
See I<set_config_rules()> for more information for what to expect inside this
rule config file and how it's used.
=cut
sub newDefineConfigRules
{
DBUG_ENTER_FUNC ( @_ );
my $prototype = shift;
my $filename = shift;
my $refresh = shift || 0; # undocumented arg requsting refresh not new obj
my $cfg;
unless ( $refresh ) {
$cfg = Advanced::Config->new ( $filename,
{ croak => 1, disable_variables => 1, tag_case => 1, source => 'x'x40 },
{ inherit => 1, required => 1 }
);
# Mark as created by this special constructor.
$cfg->{CONTROL}->{read_only} = 1;
} else {
# Requesting the reload of an existing rule cfg object
$cfg = $prototype->{PARENT} || $prototype;
unless ($cfg->_chk_if_read_only () ) {
die "This isn't a rule config object!\n";
}
$cfg->_wipe_internal_data ( $filename );
}
# Temp disable read-only setting so the data can be loaded!
local $cfg->{CONTROL}->{read_only} = 0;
# Load all the default Read, Get & Special date options.
my $rOpts = get_read_opts ();
my $gOpts = get_get_opts ();
my $sOpts = get_date_opts ();
# My special lists for what is possible per option hash.
config files requiring different options to load properly.
my $cfg = Advanced::Config->new ( "config/myData.cfg" )->
set_config_rules ($ruleCfg);
For example, let's say that B<$ruleCfg> was set up with 4 sections, myData.cfg,
*.cfg, tom*.cfg and *. And myData.cfg sources in the following 3 files.
bob.cfg, sue.config, and tomfile.cfg.
During the call to I<set_config_rules()> it finds the basename of the passed
filename, myData.cfg, and finds the section named after it and takes the rules
defined in that section and applies it to the congig object. Had this section
not existed, it would have followed the wildcard rules below.
Later on when sourcing in bob.cfg it doesn't find a section called bob.cfg, so
it attempts to lookup the section to use via wildcards and finds section
B<*.cfg>
Next when sourcing in sue.config there is no section called that and it doesn't
match wildcard sections B<*.cfg> or B<tom*.cfg>, so it uses the default section
B<*> to gather the rules from.
Finally for tomfile.cfg it matches both B<*.cfg> and B<tom*.cfg> which is a
fatal error. To get arround this error you must define a special tag called
B<__order__> and assign it an integer value. The one with the smallest value
is the name that will match. So set to 100 for B<tom*.cfg> and 654321 for
B<*.cfg> and it will match B<tom*.cfg>. It will never match B<*> since it has
an assumed B<__order__> of infinity.
=cut
sub set_config_rules
{
DBUG_ENTER_FUNC ( @_ );
my $self = shift;
my $ruleCfg = shift;
$self = $self->{PARENT} || $self;
$ruleCfg = $ruleCfg->{PARENT} || $ruleCfg;
if ( $self->_chk_if_read_only () ) {
die "You may not override rules for object created by newDefineConfigRules ()\n";
}
unless ( $ruleCfg->_chk_if_read_only () ) {
die "The ruleCfg argument must be created via newDefineConfigRules ()\n";
}
my $rule = $ruleCfg->_get_rule_section ( $self->filename () );
( $self->{CONTROL}->{read_opts},
$self->{CONTROL}->{get_opts},
$self->{CONTROL}->{date_opts} ) = $rule->_get_rules_from_cfg ();
$self->{CONTROL}->{ConfigRuleObj} = $ruleCfg;
DBUG_RETURN ( $self );
}
#######################################
# Get all rules from the config file & validate them.
sub _get_rules_from_cfg
{
DBUG_ENTER_FUNC ( @_ );
my $ruleCfg = shift;
unless ( $ruleCfg->_chk_if_read_only () ) {
die "This object must be created by newDefineConfigRules ()\n";
}
DBUG_PRINT ("DBUG", "Rule Sectoon: %s", $ruleCfg->section_name () );
my ($read_opts, $get_opts, $date_opts);
my (%read, %get, %date);
foreach ( @{$ruleCfg->get_value ( "___list_read___" )} ) {
$read{$_} = ( $ruleCfg->_base_get2 ($_) )[0];
}
$read_opts = get_read_opts ( \%read );
foreach ( @{$ruleCfg->get_value ( "___list_get___" )} ) {
$get{$_} = ( $ruleCfg->_base_get2 ($_) )[0];
}
$get_opts = get_get_opts ( \%get );
foreach ( @{$ruleCfg->get_value ( "___list_spec___" )} ) {
$date{$_} = ( $ruleCfg->_base_get2 ($_) )[0];
}
$date_opts = get_date_opts ( \%date );
DBUG_RETURN ( $read_opts, $get_opts, $date_opts );
}
#######################################
sub _get_rule_section
{
DBUG_ENTER_FUNC ( @_ );
my $ruleCfg = shift;
my $name = shift;
if ((! defined $name) || $name =~ m/^\s+$/) {
die ("Missing filename argument!\n");
}
unless ( $ruleCfg->_chk_if_read_only () ) {
die "This object must be created by newDefineConfigRules ()\n";
}
my $bName = basename ($name);
my $cfg = $ruleCfg->get_section ($bName, 0);
if (defined $cfg) {
return DBUG_RETURN ($cfg);
}
my @wild_names = $ruleCfg->find_sections ( "\\*" );
my @match_names;
my $default_name;
foreach my $s (@wild_names) {
if ( $s eq "*" ) {
# 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 {
local $opts->{required} = $req;
croak_helper ($opts, "No such tag ($tag), nor is it a date string.", undef);
return ( undef, 0, "", 0, 0, $req ); # No such tag/date ...
}
}
# The tag exists, then it must reference a date!
local $opts->{date_active} = 1;
($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 ); # Not a date ...
}
}
#######################################
=back
=head2 Accessing the contents of an Advanced::Config object.
These methods allow you to access the data loaded into this object.
They all look in the current section for the B<tag> and if the B<tag> couldn't
be found in this section and the I<inherit> option was also set, it will then
look in the parent/main section for the B<tag>. But if the I<inherit> option
wasn't set it wouldn't look there.
If the requested B<tag> couldn't be found, they return B<undef>. But if the
I<required> option was used, it may call B<die> instead!
But normally they just return the requested B<tag>'s value.
They all use F<%override_get_opts>, passed by value or by reference, as an
optional argument that overrides the default options provided in the call
to F<new()>. The I<inherit> and I<required> options discussed above are two
such options. In most cases this hash argument isn't needed. So leave it off
if you are happy with the current defaults!
See the POD under L<Advanced::Config::Options>, I<The Get Options> for more
details on what options you may override.
Only the B<L<get_value>> function was truly needed. But the other I<get>
methods were added for a couple of reasons. First to make it clear in your code
what type of value is being returned and provide the ability to do validation of
the B<tag>'s value without having to validate it yourself! Another benefit was
that it drastically reduced the number of exposed I<Get Options> needed for this
module. Making it easier to use.
Finally when these extra methods apply their validation, if the B<tag>'s value
fails the test, it treats it as a I<B<tag> not found> situation as described
above.
=over
=item $value = $cfg->get_value ( $tag[, %override_get_opts] );
This function looks up the requested B<tag>'s value and returns it.
See common details above.
=cut
sub get_value
{
DBUG_ENTER_FUNC ( @_ );
my $self = shift; # Reference to the current section.
my $tag = shift; # The tag to look up ...
my $opt_ref = $_[0]; # The override options ...
$opt_ref = $self->_get_opt_args ( @_ ) if ( defined $opt_ref );
my ( $value, $sensitive ) = $self->_base_get2 ( $tag, $opt_ref );
DBUG_MASK (0) if ( $sensitive );
DBUG_RETURN ( $value );
}
#######################################
# A helper function to handle the various ways to find a hash as an argument!
# Handles all 3 cases.
# undef - No arguments
# hash ref - passed by reference
# something else - passed by value. (array)
sub _get_opt_args
{
my $self = shift; # Reference to the current section.
my $opt_ref = $_[0]; # May be undef, a hash ref, or start of a hash ...
# Convert the parameter array into a regular old hash reference ...
my %opts;
unless ( defined $opt_ref ) {
$opt_ref = \%opts;
} elsif ( ref ($opt_ref) ne "HASH" ) {
%opts = @_;
$opt_ref = \%opts;
}
return ( $opt_ref ); # The hash reference to use ...
}
#######################################
# Another helper function to help with evaluating which value to use ...
# Does a 4 step check.
# 1) Use the $value if provided.
# 2) If the key exists in the hash returned by _get_opt_args(), use it.
( run in 0.788 second using v1.01-cache-2.11-cpan-d01c6094234 )