Advanced-Config
view release on metacpan or search on metacpan
lib/Advanced/Config/Reader.pm view on Meta::CPAN
my $sect_str = convert_to_regexp_string ($opts->{source_file_section_lbl});
my $export_str = convert_to_regexp_string ($opts->{export_lbl});
my ($lb, $rb) = ( convert_to_regexp_string ($opts->{section_left}),
convert_to_regexp_string ($opts->{section_right}) );
my $assign_str = convert_to_regexp_string ($opts->{assign});
my $src_str = convert_to_regexp_string ($opts->{source});
my ($lv, $rv) = ( convert_to_regexp_string ($opts->{variable_left}),
convert_to_regexp_string ($opts->{variable_right}) );
# The label separators used when searching for option labels in a comment ...
my $lbl_sep = '[\s.,$!()-]';
# Initialize to the default secion ...
my $section = make_new_section ( $cfg, "" );
my %hide_section;
while ( <$READ_CONFIG> ) {
chomp;
my $line = $_; # Save so can use in fish logging later on.
my ($tv, $ln, $cmt, $lq, $rq) = parse_line ( $line, $opts );
if ( $ln eq "" ) {
DBUG_PRINT ("READ", "READ LINE: %s", $line);
next; # Skip to the next line if only comments found.
}
# Check for lines with no tag/value pairs in them ...
if ( ! $tv ) {
DBUG_PRINT ("READ", "READ LINE: %s", $line);
# EX: . ${file} --- Sourcing in ${file} ...
if ( $ln =~ m/^${src_str}\s+(.+)$/i ) {
my $src = $1;
my $def_section = "";
if ( $cmt =~ m/(^|${lbl_sep})${sect_str}(${lbl_sep}|$)/ ) {
$def_section = $section;
}
my $res = source_file ( $cfg, $def_section, $src, $file );
return DBUG_RETURN (0) unless ( $res );
next;
}
# EX: [ ${section} ] --- Starting a new section ...
if ( $ln =~ m/^${lb}\s*(.+?)\s*${rb}$/ ) {
$section = make_new_section ( $cfg, $1 );
$hide_section{$section} = 0; # Assume not sensitive ...
if ( $cmt =~ m/(^|${lbl_sep})${hide_str}(${lbl_sep}|$)/ ||
should_we_hide_sensitive_data ( $section ) ) {
$hide_section{$section} = 1;
}
next;
}
# Don't know what the config file was thinking of ...
# Don't bother expanding any variables encountered.
DBUG_PRINT ("error", "<Previous line ignored. Unknown format!>");
next;
}
# ------------------------------------------------------------------
# If you get here, you know it's a tag/value pair to parse ...
# Don't forget that any comment can include processing instructions!
# ------------------------------------------------------------------
# Go to the requested section ...
$cfg = $pcfg->get_section ( $section, 1 );
my ($tag, $value, $prefix, $t2) = _split_assign ( $opts, $ln );
# Don't export individually if doing a batch export ...
# If the export option is used, invert the meaning ...
my $export_flag = 0; # Assume not exporting this tag to %ENV ...
if ( $prefix ) {
$export_flag = $opts->{export} ? 0 : 1;
} elsif ( $cmt =~ m/(^|${lbl_sep})${export_str}(${lbl_sep}|$)/ ) {
$export_flag = $opts->{export} ? 0 : 1;
}
# Is the line info sensitive & should it be hidden/masked in fish ???
my $hide = 0;
if ( $hide_section{$section} ||
$cmt =~ m/(^|${lbl_sep})${encrypt_str}(${lbl_sep}|$)/ ||
$cmt =~ m/(^|${lbl_sep})${hide_str}(${lbl_sep}|$)/ ||
should_we_hide_sensitive_data ( $tag, 1 ) ) {
$hide = 1 unless ( $opts->{dbug_test_use_case_hide_override} );
}
if ( $hide ) {
# Some random length so we can't assume the value from the mask used!
my $mask = "*"x8;
if ( $value eq "" ) {
if ( is_assign_spaces ( $opts ) ) {
$line =~ s/^(\s*\S+\s+)/${1}${mask} /;
} else {
$line =~ s/(\s*${assign_str})\s*/${1} ${mask} /;
}
} else {
my $hide_value = convert_to_regexp_string ( $value, 1 );
if ( is_assign_spaces ( $opts ) ) {
$line =~ s/^(\s*\S+\s+)${hide_value}/${1}${mask}/;
} else {
$line =~ s/(\s*${assign_str}\s*)${hide_value}/${1}${mask}/;
}
}
} elsif ( $cmt =~ m/(^|${lbl_sep})${decrypt_str}(${lbl_sep}|$)/ ) {
# Don't hide the line in fish, but hide it's value processing ...
$hide = 1 unless ( $opts->{dbug_test_use_case_hide_override} );
}
DBUG_PRINT ("READ", "READ LINE: %s", $line);
# Remove any balanced quotes ... (must do after hide)
$value =~ s/^${lq}(.*)${rq}$/$1/ if ( $lq );
if ( $tag =~ m/^(shft3+)$/i ) {
lib/Advanced/Config/Reader.pm view on Meta::CPAN
DBUG_RETURN (1);
}
# ==============================================================
=item $boolean = source_file ($config, $def_sct, $new_file, $curr_file)
This is a private method called by I<read_config> to source in the requested
config file and merge the results into the current config file.
If I<$def_sct> is given, it will be the name of the current section that the
sourced in file is to use for it's default unlabeled section. If the default
section name has been hard coded in the config file, this value overrides it.
The I<$new_file> may contain variables and after they are expanded the
source callback function is called before I<load_config()> is called.
See L<Advanced::Config::lookup_one_variable> for rules on variable expansion.
If I<$new_file> is a relative path, it's a relative path from the location
of I<$curr_file>, not the program's current directory!
If a source callback was set up, it will call it here.
This method will also handle the removal of decryption related options if new
ones weren't provided by the callback function. See Advanced::Config::Options
for more details.
Returns B<1> if the new file successfully loaded. Else B<0> if something went
wrong during the load!
=cut
sub source_file
{
DBUG_ENTER_FUNC (@_);
my $cfg = shift;
my $defaultSection = shift; # The new default section if not "".
my $new_file = shift; # May contain variables to expand ...
my $old_file = shift; # File we're currently parsing. (has abs path)
my $rOpts = $cfg->get_cfg_settings (); # The Read Options ...
local $global_sections{OVERRIDE} = $defaultSection if ( $defaultSection );
my $pcfg = $cfg->get_section (); # Back to the main/default section ...
my $file = $new_file = expand_variables ($pcfg, $new_file, undef, undef, 1);
# Get the full name of the file we're sourcing in ...
$file = $pcfg->_fix_path ( $file, dirname ( $old_file ) );
unless ( -f $file && -r _ ) {
my $msg = "No such file to source in or it's unreadable ( $file )";
return DBUG_RETURN ( croak_helper ( $rOpts, $msg, 0 ) );
}
if ( $cfg->_recursion_check ( $file ) ) {
my $msg = "Recursion detected while sourcing in file ( $new_file )";
if ( $rOpts->{trap_recursion} ) {
# The request is a fatal error!
return DBUG_RETURN ( croak_helper ( $rOpts, $msg, 0 ) );
} else {
DBUG_PRINT ("RECURSION", $msg);
return DBUG_RETURN ( 1 ); # Just ignore the request ...
}
}
# The returned callback option(s) will be applied to the current
# settings, not the default settings if not a compete set!
my ($r_opts, $d_opts);
if ( exists $rOpts->{source_cb} && ref ( $rOpts->{source_cb} ) eq "CODE" ) {
($r_opts, $d_opts) = $rOpts->{source_cb}->( $file, $rOpts->{source_cb_opts} );
}
if ( $rOpts->{inherit_pass_phase} && $rOpts->{pass_phrase} ) {
my %empty;
$r_opts = \%empty unless ( defined $r_opts );
$r_opts->{pass_phrase} = $rOpts->{pass_phrase} unless ( $r_opts->{pass_phrase} );
}
my $res = $pcfg->_load_config_with_new_date_opts ( $file, $r_opts, $d_opts );
DBUG_RETURN ( (defined $res) ? 1 : 0 );
}
# ==============================================================
=item $name = make_new_section ($config, $section)
This is a private method called by I<read_config> to create a new section
in the L<Advanced::Config> object if a section of that name doesn't already
exist.
The I<$section> name is allowed to contain variables to expand before the
string is used. But those variables must be defined in the I<main> section.
Returns the name of the section found/created in lower case.
=cut
sub make_new_section
{
DBUG_ENTER_FUNC (@_);
my $config = shift;
my $new_name = shift;
# Check if overriding the default section with a new name ...
if ( $new_name eq "" || $new_name eq $global_sections{DEFAULT} ) {
if ( $global_sections{DEFAULT} ne $global_sections{OVERRIDE} ) {
DBUG_PRINT ("OVERRIDE", "Overriding section '%s' with section '%s'",
$new_name, $global_sections{OVERRIDE});
$new_name = $global_sections{OVERRIDE};
}
}
my $pcfg = $config->get_section (); # Back to the main section ...
my $val = expand_variables ($pcfg, $new_name, undef, undef, 1);
$new_name = lc ( $val );
lib/Advanced/Config/Reader.pm view on Meta::CPAN
This function takes the rule specified by I<$rule> and applies it against
the I<$value> with assistance from the I<$sub_rule>.
It returns the edited I<value> and whether applying the modifier made it
I<sensitive>. (-1 means it's an encrypted value. -2 means it's the variable
name that resolves to an encrypted value. 0 - Non-sensitive, 1 - Sensitive.)
See L<https://web.archive.org/web/20200309072646/https://wiki.bash-hackers.org/syntax/pe>
for information on how this can work. This module supports most of the
parameter expansions listed there except for those dealing with arrays. Other
modifier rules may be added upon request.
=cut
# NOTE1: Fish has already been paused if $tag is sensitive. Since this method
# has no idea if the current tag is sensitive or not.
# NOTE2: But still need to mask the return value if referencing sensitive data
# in case the original $tag wasn't sensitive. So in most cases it will
# return not-sensitive even if fish has already been paused!
#
# NOTE3: If sensitive/mask is -1, it's sensitive and not decrypted. In this
# case the returned value is the tag's name, not it's value!
sub apply_modifier
{
DBUG_ENTER_FUNC ( @_ );
my $cfg = shift;
my $value = shift; # The value for ${mod_tag} ...
my $mod_tag = shift; # The tag to apply the rule against!
my $mod_opt = shift; # The rule ...
my $mod_val = shift; # The sub-rule ...
my $file = shift; # The file the tag's from.
my $alt_val = (defined $value) ? $value : "";
# The values to return ...
my $output;
# Values: 0 - Normal non-sensitive return value (99.9% of the time)
# 1 - Sensitive return value.
# -1 - Return value is encrypted.
# -2 - Return value is variable name of encrypted value.
my $mask = 0;
# If looking for a default value ...
if ( ( $mod_opt eq ":+" && $alt_val ne "" ) ||
( $mod_opt =~ m/^:[-=?]$/ && $alt_val eq "" ) ||
( $mod_opt eq "+" && defined $value ) ||
( $mod_opt =~ m/^[-=?]$/ && ! defined $value ) ) {
$output = $mod_val; # Now uses this value as it's default!
if ( $mod_opt eq ":=" || $mod_opt eq "=" ) {
# The variable either doesn't exist or it resolved to "".
# This variant rule says to also set the variable to this value!
$cfg->_base_set ( $mod_tag, $output, $file );
} elsif ( $mod_opt eq ":?" || $mod_opt eq "?" ) {
# In shell scripts, ":?" would cause your script to die with the
# default value as the error message if your var had no value.
# Repeating that logic here.
my $msg = "Encounterd undefined variable ($mod_tag) using shell modifier ${mod_opt}";
$msg .= " in config file: " . basename ($file) if ( $file ne "" );
DBUG_PRINT ("MOD", $msg);
die ( basename ($0) . ": ${mod_tag}: ${output}.\n" );
}
DBUG_PRINT ("MOD",
"The modifier (%s) is overriding the variable with a default value!",
$mod_opt);
# Sub-string removal ...
} elsif ( $mod_opt eq "##" || $mod_opt eq "#" || # From beginning
$mod_opt eq "%%" || $mod_opt eq "%" ) { # From end
my $greedy = ( $mod_opt eq "##" || $mod_opt eq "%%" );
my $leading = ( $mod_opt eq "#" || $mod_opt eq "##" );
my $reverse_msg = ""; # Both the message & control flag ...
$output = $alt_val;
# Now replace shell script wildcards with their Perl equivalents.
# A RegExp can't do non-greedy replaces anchored to the end of string!
# So we need the reverse logic to do so.
my $regExpVal = convert_to_regexp_modifier ($mod_val);
$regExpVal =~ s/[?]/./g; # ? --> . (any one char)
if ( $greedy ) {
$regExpVal =~ s/[*]/.*/g; # * --> .* (zero or more greedy chars)
} elsif ( $leading ) {
$regExpVal =~ s/[*]/(.*?)/g; # * --> (.*?) (zero or more chars)
} elsif ( $regExpVal =~ m/[*]/ ) {
# Non-Greedy with one or more wild cards present ("*")!
$leading = 1; # Was false before.
$regExpVal = reverse ($regExpVal);
$regExpVal =~ s/[*]/(.*?)/g; # * --> (.*?) (zero or more chars)
$output = reverse ($output);
$reverse_msg = " Reversed for non-greedy strip.";
}
if ( $leading ) {
$regExpVal = '^' . $regExpVal;
} else {
# Either greedy trailing or no *'s in trailing regular expression!
$regExpVal .= '$';
}
$output =~ s/${regExpVal}//; # Strip off the matching values ...
$output = reverse ($output) if ( $reverse_msg ne "" );
DBUG_PRINT ("MOD",
"The modifier (%s) converted \"%s\" to \"%s\".%s\nTo trim the value to: %s",
$mod_opt, $mod_val, $regExpVal, $reverse_msg, $output);
} elsif ( $mod_opt eq "LENGTH" ) {
$output = length ( $alt_val );
DBUG_PRINT ("MOD", "Setting the length of variable \${#%s} to: %d.",
$mod_tag, $output);
} elsif ( $mod_opt eq "LIST" ) {
my @lst = $cfg->_find_variables ( $mod_val );
$output = join (" ", @lst);
lib/Advanced/Config/Reader.pm view on Meta::CPAN
unless ( $quote_l ) {
my $v = $rOpts->{variable_left} . "shft3" . $rOpts->{variable_right};
$value =~ s/${cmt}/${v}/g;
}
}
# Surround the value with quotes!
if ( $quote_l ) {
$value = ${quote_l} . ${value} . ${quote_r};
}
my $line = ${tag} . " " . $rOpts->{assign} . " " . ${value};
DBUG_RETURN ( $line );
}
# ==============================================================
=item $string = format_encrypt_cmt ( \%rOpts )
Uses the given I<Read Options Hash> to generate a comment suitable for use
in marking a tag/value pair as ready to be encrypted.
=cut
sub format_encrypt_cmt
{
DBUG_ENTER_FUNC ( @_ );
my $rOpts = shift;
DBUG_RETURN ( $rOpts->{comment} . " " . $rOpts->{encrypt_lbl} );
}
# ==============================================================
=item $status = encrypt_config_file_details ( $file, $writeFile, \%rOpts )
This function encrypts all tag values inside the specified config file that are
marked as ready for encryption and generates a new config file with everything
encrypted. If a tag/value pair isn't marked as ready for encryption it is left
alone. By default this label is B<ENCRYPT>.
After a tag's value has been encrypted, the label in the comment is updated
from B<ENCRYPT> to B<DECRYPT> in the new file.
If you are adding new B<ENCRYPT> tags to an existing config file that already
has B<DECRYPT> tags in it, you must use the same encryption related options in
I<%rOpts> as the last time. Otherwise you won't be able to decrypt all
encrypted values.
This method ignores any request to source in other config files. You must
encrypt each file individually.
It writes the results of the encryption process to I<$writeFile>.
See L<Advanced::Config::Options> for some caveats about this process.
Returns: B<1> if something was encrypted. B<-1> if nothing was encrypted.
Otherwise B<0> on error.
=cut
sub encrypt_config_file_details
{
DBUG_ENTER_FUNC ( @_ );
my $file = shift;
my $scratch = shift;
my $rOpts = shift;
unlink ( $scratch );
# The labels to search for ...
my $decrypt_str = convert_to_regexp_string ($rOpts->{decrypt_lbl});
my $encrypt_str = convert_to_regexp_string ($rOpts->{encrypt_lbl});
my $hide_str = convert_to_regexp_string ($rOpts->{hide_lbl});
my $assign_str = convert_to_regexp_string ($rOpts->{assign});
my ($lb, $rb) = ( convert_to_regexp_string ($rOpts->{section_left}),
convert_to_regexp_string ($rOpts->{section_right}) );
# The label separators used when searching for option labels in a comment ...
my $lbl_sep = '[\s.,$!-()]';
my $mask = "*"x8;
DBUG_PRINT ("INFO", "Opening for reading the config file named: %s", $file);
unless ( open (ENCRYPT, "<", $file) ) {
return DBUG_RETURN ( croak_helper ($rOpts,
"Unable to open the config file.", 0) );
}
DBUG_PRINT ("INFO", "Creating scratch file named: %s", $scratch);
unless ( open (NEW, ">", $scratch) ) {
close (ENCRYPT);
return DBUG_RETURN ( croak_helper ($rOpts,
"Unable to create the scratch config file.", 0) );
}
# Misuse of this option makes the config file unreadable ...
if ( $rOpts->{use_utf8} ) {
binmode (ENCRYPT, "encoding(UTF-8)");
binmode (NEW, "encoding(UTF-8)");
}
my $errMsg = "Unable to write to the scratch file.";
my $hide_section = 0;
my $count = 0;
while ( <ENCRYPT> ) {
chomp;
my $line = $_;
my ($tv, $ln, $cmt, $lq, $rq) = parse_line ( $line, $rOpts );
my ($hide, $encrypt) = (0, 0);
my ($tag, $value, $prefix, $t2);
if ( $tv ) {
lib/Advanced/Config/Reader.pm view on Meta::CPAN
# Modify the label in the comment ...
my $lbl = $rOpts->{decrypt_lbl};
$cmt =~ s/(^|${lbl_sep})${encrypt_str}(${lbl_sep}|$)/$1${lbl}$2/g;
# Remove any balanced quotes from arround the value ...
if ( $lq ) {
$value =~ s/^${lq}//;
$value =~ s/${rq}$//;
}
my ($new_value, $nlq, $nrq);
$new_value = encrypt_value ( $value, $t2, $rOpts, $file);
($new_value, $nlq, $nrq) = _apply_escape_sequences ( $new_value, $rOpts );
if ( is_assign_spaces ( $rOpts ) ) {
$line =~ s/^(\s*\S+\s+)${old_value}/$1${nlq}${new_value}${nrq}/;
} else {
$line =~ s/(\s*${assign_str}\s*)${old_value}/$1${nlq}${new_value}${nrq}/;
}
$line =~ s/${old_cmt}$/${cmt}/;
unless (print NEW $line, "\n") {
return DBUG_RETURN ( croak_helper ($rOpts, $errMsg, 0) );
}
} # End the while ENCRYPT loop ...
close (ENCRYPT);
close (NEW);
my $status = ($count == 0) ? -1 : 1;
DBUG_RETURN ( $status );
}
# ==============================================================
=item $status = decrypt_config_file_details ( $file, $writeFile, \%rOpts )
This function decrypts all tag values inside the specified config file that are
marked as encrypted and generates a new file with everything decrypted. If a
tag/value pair isn't marked as being encrypted it is left alone. By default
this label is B<DECRYPT>.
After a tag's value has been decrypted, the label in the comment is updated
from B<DECRYPT> to B<ENCRYPT> in the config file.
For this to work, the encryption related options in I<\%rOpts> must match what
was used in the call to I<encrypt_config_file_details> or the decryption will
fail.
This method ignores any request to source in other config files. You must
decrypt each file individually.
It writes the results of the decryption process to I<$writeFile>.
See L<Advanced::Config::Options> for some caveats about this process.
Returns: B<1> if something was decrypted. B<-1> if nothing was decrypted.
Otherwise B<0> on error.
=cut
sub decrypt_config_file_details
{
DBUG_ENTER_FUNC ( @_ );
my $file = shift;
my $scratch = shift;
my $rOpts = shift;
unlink ( $scratch );
# The labels to search for ...
my $decrypt_str = convert_to_regexp_string ($rOpts->{decrypt_lbl});
my $encrypt_str = convert_to_regexp_string ($rOpts->{encrypt_lbl});
my $hide_str = convert_to_regexp_string ($rOpts->{hide_lbl});
# The label separators used when searching for option labels in a comment ...
my $lbl_sep = '[\s.,$!-()]';
my $assign_str = convert_to_regexp_string ($rOpts->{assign});
my ($lb, $rb) = ( convert_to_regexp_string ($rOpts->{section_left}),
convert_to_regexp_string ($rOpts->{section_right}) );
my $mask = "*"x8;
DBUG_PRINT ("INFO", "Opening for reading the config file named: %s", $file);
unless ( open (DECRYPT, "<", $file) ) {
return DBUG_RETURN ( croak_helper ($rOpts,
"Unable to open the config file.", 0) );
}
DBUG_PRINT ("INFO", "Creating scratch file named: %s", $scratch);
unless ( open (NEW, ">", $scratch) ) {
close (DECRYPT);
return DBUG_RETURN ( croak_helper ($rOpts,
"Unable to create the scratch config file.", 0) );
}
# Misuse of this option makes the config file unreadable ...
if ( $rOpts->{use_utf8} ) {
binmode (DECRYPT, "encoding(UTF-8)");
binmode (NEW, "encoding(UTF-8)");
}
my $errMsg = "Unable to write to the scratch file.";
my $hide_section = 0;
my $count = 0;
while ( <DECRYPT> ) {
chomp;
my $line = $_;
my ($tv, $ln, $cmt, $lq, $rq) = parse_line ( $line, $rOpts );
my ($hide, $decrypt) = (0, 0);
my ($tag, $value, $prefix, $t2);
if ( $tv ) {
( run in 0.753 second using v1.01-cache-2.11-cpan-140bd7fdf52 )