Advanced-Config
view release on metacpan or search on metacpan
lib/Advanced/Config/Reader.pm view on Meta::CPAN
}
# ==============================================================
# Allows a config file to run a random command when it's loaded into memory.
# Only allowed if explicity enabled & configured!
# Decided it's too dangerous to use, so never called outside of a POC example!
sub _execute_backquoted_cmd
{
my $rOpts = shift;
my $hide = shift;
my $tag = shift;
my $value = shift;
return ( $value ) unless ( $rOpts->{enable_backquotes} );
# Left & right backquotes ...
my ($lbq, $rbq) = ( convert_to_regexp_string ($rOpts->{backquote_left}, 1),
convert_to_regexp_string ($rOpts->{backquote_right}, 1) );
unless ( $value =~ m/^${lbq}(.*)${rbq}$/ ) {
return ( $value ); # No balanced backquotes detected ...
}
my $cmd = $1; # The command to run ...
# DBUG_MASK_NEXT_FUNC_CALL (3) if ( $hide ); # Never hide value (cmd to run)
DBUG_ENTER_FUNC ($rOpts, $hide, $tag, $value, @_);
DBUG_MASK (0) if ( $hide ); # OK to hide the results.
if ( $cmd =~ m/[`]/ ) {
DBUG_PRINT ('INFO', 'Your command may not have backquotes (`) in it!');
} elsif ( $cmd =~ m/^\s*$/ ) {
DBUG_PRINT ('INFO', 'Your command must have a value!');
} else {
die ("Someone tried to run cmd: $cmd\n");
# $value = `$cmd`;
$value = "" unless ( defined $value );
chomp ($value);
}
DBUG_RETURN ($value);
}
# ==============================================================
=item @ret[0..4] = parse_line ( $input, \%opts )
This is a private method called by I<read_config> to parse each line of the
config file as it's read in. It's main purpose is to strip off leading and
trailing spaces and any comments it might find on the input line. It also
tells if the I<$input> contains a tag/value pair.
It returns 5 values: ($tv_flg, $line, $comment, $lQuote, $rQuote)
B<$tv_flg> - True if I<$line> contains a tag/value pair in it, else false.
B<$line> - The trimmed I<$input> line minus any comments.
B<$comment> - The comment stripped out of the original input line minus the
leading comment symbol(s).
B<$lQuote> & B<rQuote> - Only set if I<$tv_flg> is true and I<$lQuote> was
the 1st char of the value and I<$rQuote> was the last char of the tag's value.
If the value wasn't surrounded by balanced quotes, both return values will be
the empty string B<"">.
If these quotes are returned, it expects the caller to remove them from the
tag's value. The returned values for these quote chars are suitable for use as
is in a RegExpr. The caller must do this in order to preserve potential
leading/trailing spaces.
=cut
sub parse_line
{
DBUG_MASK_NEXT_FUNC_CALL (0); # Masks ${line}!
DBUG_ENTER_FUNC ( @_ );
my $line = shift;
my $opts = (ref ($_[0]) eq "HASH" ) ? $_[0] : {@_};
# Mask the ${line} return value in fish ...
# Only gets unmasked in the test scripts: t/*.t.
# Always pause since by the time we detect if it should be
# hidden or not it's too late. We've already written it to fish!
unless ( $opts->{dbug_test_use_case_parse_override} ) {
DBUG_MASK ( 1 );
DBUG_PAUSE ();
}
# Strip of leading & trailing spaces ...
$line =~ s/^\s+//;
$line =~ s/\s+$//;
my $default_quotes = using_default_quotes ( $opts );
my $comment = convert_to_regexp_string ($opts->{comment}, 1);
my ($tag, $value) = _split_assign ( $opts, $line, 1 );
my ($l_quote, $r_quote, $tv_pair_flag) = ("", "", 0);
my $var_line = $line;
unless ( defined $tag && defined $value ) {
$tag = $value = undef; # It's not a tag/value pair ...
} elsif ( $tag eq "" || $tag =~ m/${comment}/ ) {
$tag = $value = undef; # It's not a valid tag ...
} else {
# It looks like a tag/value pair to me ...
$tv_pair_flag = 1;
if ( $opts->{disable_quotes} ) {
; # Don't do anything ...
} elsif ( $default_quotes ) {
if ( $value =~ m/^(['"])/ ) {
$l_quote = $r_quote = $1; # A ' or ". (Never both)
}
lib/Advanced/Config/Reader.pm view on Meta::CPAN
# Rebuild the output string so we can look for more variables ...
if ( defined $val ) {
$output = $left . $val . $right;
} else {
$output = $left . $right;
}
# Get the next variable to evaluate ...
($left, $tag, $right, $cmt_flag, $mod_tag, $mod_opt, $mod_val, $ot) =
parse_for_variables ( $output, 0, $opts );
} # End while ( defined $tag ) loop ...
# Restore all place holders back into the output string with the
# proper variable name. Have to assume still sensitive even if
# all the placeholders drop out. Since can't tell what else may
# have triggered it.
if ( $mask_flag == -1 ) {
$mask_flag = 1; # Mark sensitive ...
foreach ( keys %encrypt_vars ) {
my $val = $opts->{variable_left} . $encrypt_vars{$_} . $opts->{variable_right};
$mask_flag = -1 if ( $output =~ s/$_/$val/ );
}
}
# Did the variable substitution result in the need to trim things?
if ( $trim_flag ) {
$output =~ s/^\s+//;
$output =~ s/\s+$//;
}
DBUG_RETURN ( $output, $mask_flag );
}
# ==============================================================
=item ($v[, $s]) = apply_modifier ( $config, $value, $tag, $rule, $sub_rule, $file )
This is a helper method to F<expand_variables>. Not for public use.
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;
lib/Advanced/Config/Reader.pm view on Meta::CPAN
} else {
DBUG_PRINT ("MOD",
"The modifier (%s) didn't affect the variable's value!",
$mod_opt);
$output = $value;
}
DBUG_RETURN ( $output, $mask );
}
# ==============================================================
=item @ret[0..7] = parse_for_variables ( $value, $ignore_disable_flag, $rOpts )
This is a helper method to F<expand_variables> and B<parse_line>.
This method parses the I<$value> to see if any variables are defined in it
and returns the information about it. If there is more than one variable
present in the I<$value>, only the 1st variable/tag to evaluate is returned.
By default, a variable is the tag in the I<$value> between B<${> and B<}>, which
can be overridden with other anchor patterns. See L<Advanced::Config::Options>
for more details on this.
If you've configured the module to ignore variables, it will never find any.
Unless you also set I<$ignore_disable_flag> to a non-zero value.
Returns B<8> values. ( $left, $tag, $right, $cmt, $sub_tag, $sub_opr, $sub_val,
$otag )
All B<8> values will be I<undef> if no variables were found in I<$value>.
Otherwise it returns at least the 1st four values. Where I<$tag> is the
variable that needs to be looked up. And the caller can join things back
together as "B<$left . $look_up_value . $right>" after the variable substitution
is done and before this method is called again to locate additional variables in
the resulting new I<$value>.
The 4th value I<$cmt>, will be true/false based on if B<$left> has a comment
symbol in it! This flag only has meaning to B<parse_line>. And is terribly
misleading to other users.
Should the I<$tag> definition have one of the supported shell script variable
modifiers embedded inside it, then the I<$tag> will be parsed and the 3 B<sub_*>
return values will be calculated as well. See
L<http://wiki.bash-hackers.org/syntax/pe> for more details. Most of the
modifiers listed there are supported except for those dealing with arrays.
See I<apply_modifier> for applying these rules against the returned I<$tag>.
Other modifier rules may be added upon request.
These 3 B<sub_*> return values will always be I<undef> should the variable
left/right anchors be overridden with the same value. Or if no modifiers
are detected in the tag's name.
If you've configured the module to be case insensitive (option B<tag_case>),
then both I<$tag> and I<$sub_tag> will be shifted to lower case for case
insensitive variable lookups.
Finally there is an 8th return value, I<$otag>, that contains the original
I<$tag> value before it was edited. Needed by F<parse_line> logic.
=cut
# WARNING: If (${lvar} == ${rvar}), nested variables are not supported.
# : And neither are variable modifiers. (The sub_* return values.)
# : So evaluate tags left to right.
# : If (${lvar} != ${rvar}), nested variables are supported.
# : So evaluate inner most tags first. And then left to right.
#
# RETURNS: 8 values. ( $left, $tag, $right, $cmt, $sub_tag, $sub_opr, $sub_val, $otag )
# : The 3 sub_* vars are usually undef.
# : But when set, all 3 sub_* vars are set! And $tag != $sub_tag.
#
# NOTE 1 : If the 3 sub_* vars are populated, you'd get something like this
# : for the tag & sub_* vars.
# : tag : "abc:-Default Value" - the ${...} was removed.
# : sub_tag : "abc" - the ${...} & modifier were removed.
# : sub_opr : ":-"
# : sub_val : "Default Value"
# : So if the "tag" exists as a variable, the sub_* values are ignored.
# : But if "tag" doesn't exist as a variable, then we apply the
# : sub_* rules!
#
# NOTE 2 : If the sub_* vars undef, you'd get something like this without any
# : modifiers.
# : tag : tag - the ${...} was removed.
#
# NOTE 3 : For some alternate variable anchors, the sub_* vars will almost
# : always be undef. Since the code base won't allow you to redefine
# : these modifiers when they conflict with the variable anchors.
sub parse_for_variables
{
DBUG_ENTER_FUNC ( @_ );
my $value = shift;
my $disable_flag = shift;
my $opts = shift;
my ($left, $s1, $tag, $s2, $right, $otag);
my $cmt_flg = 0;
my ($sub_tag, $sub_opr, $sub_val, $sub_extra);
if ( $opts->{disable_variables} && (! $disable_flag) ) {
DBUG_PRINT ("INFO", "Variable substitution has been disabled.");
return DBUG_RETURN ( $left, $tag, $right, $cmt_flg,
$sub_tag, $sub_opr, $sub_val, $otag );
}
my $lvar = convert_to_regexp_string ($opts->{variable_left}, 1);
my $rvar = convert_to_regexp_string ($opts->{variable_right}, 1);
# Break up the value into it's component parts. (Non-greedy RegExpr)
if ( $value =~ m/(^.*?)(${lvar})(.*?)(${rvar})(.*$)/ ) {
($left, $s1, $tag, $s2, $right) = ($1, $2, $3, $4, $5);
$otag = $tag;
# Did a comment symbol apear before the 1st ${lvar} in the line?
my $cmt_str = convert_to_regexp_string ($opts->{comment}, 1);
$cmt_flg = 1 if ( $left =~ m/${cmt_str}/ );
lib/Advanced/Config/Reader.pm view on Meta::CPAN
# ==============================================================
=item $value = encrypt_value ($value, $tag, $rOpts, $file)
Takes the I<$value> and encrypts it using the other B<3> args as part of the
encryption key. To successfully decrypt it again you must pass the same B<3>
values for these args to the I<decrypt_value()> call.
See L<Advanced::Config::Options> for some caveats about this process.
=cut
sub encrypt_value
{
DBUG_MASK_NEXT_FUNC_CALL (0); # Masks ${value} ...
DBUG_ENTER_FUNC ( @_ );
my $value = shift; # In clear text ...
my $tag = shift;
my $rOpts = shift;
my $file = shift;
# Using the file or the alias?
my $alias = basename ( ( $rOpts->{alias} ) ? $rOpts->{alias} : $file );
# ---------------------------------------------------------------
# Call the custom encryption call back method ...
# ---------------------------------------------------------------
if ( exists $rOpts->{encrypt_cb} && ref ( $rOpts->{encrypt_cb} ) eq "CODE" ) {
$value = $rOpts->{encrypt_cb}->( 1, $tag, $value, $alias, $rOpts->{encrypt_cb_opts} );
}
# ---------------------------------------------------------------
# Pad the value out to a minimum lenth ...
# ---------------------------------------------------------------
my $len1 = length ($value);
my $len2 = length ($tag);
my $len = ($len1 > $len2) ? $len1 : $len2;
my $len3 = length ($rOpts->{pass_phrase});
$len = ( $len > $len3) ? $len : $len3;
# Enforce a minimum length for the value ... (will always end in spaces)
$len = ($len < 12) ? 15 : ($len + 3);
$value = sprintf ("%-*s", $len, $value . "|");
# ---------------------------------------------------------------
# Encrypt the value via this module ...
# ---------------------------------------------------------------
$value = _encrypt ( $value, $rOpts->{pass_phrase}, $tag, $alias, $rOpts->{encrypt_by_user} );
DBUG_RETURN ( $value );
}
# ==============================================================
=item $value = decrypt_value ($value, $tag, $rOpts, $file)
Takes the I<$value> and decrypts it using the other B<3> args as part of the
decryption key. To successfully decrypt it the values for these B<3> args
must match what was passed to I<encryption_value()> when the value was
originally encrypted.
See L<Advanced::Config::Options> for some caveats about this process.
=cut
sub decrypt_value
{
DBUG_ENTER_FUNC ( @_ );
my $value = shift; # It's encrypted ...
my $tag = shift;
my $rOpts = shift;
my $file = shift;
DBUG_MASK (0); # Mask the return value ... It's sensitive by definition!
# Using the file or the alias?
my $alias = basename ( ( $rOpts->{alias} ) ? $rOpts->{alias} : $file );
# ---------------------------------------------------------------
# Decrypt the value via this module ...
# ---------------------------------------------------------------
$value = _encrypt ( $value, $rOpts->{pass_phrase}, $tag, $alias, $rOpts->{encrypt_by_user} );
$value =~ s/\|[\s\0]+$//; # Trim any trailing spaces or NULL chars.
# ---------------------------------------------------------------
# Call the custom decryption call back method ...
# ---------------------------------------------------------------
if ( exists $rOpts->{encrypt_cb} && ref ( $rOpts->{encrypt_cb} ) eq "CODE" ) {
$value = $rOpts->{encrypt_cb}->( 0, $tag, $value, $alias, $rOpts->{encrypt_cb_opts} );
}
DBUG_RETURN ( $value );
}
# ==============================================================
# Before writing an encrypted value to a config file, all problem
# character sequences must be converted into escape sequences. So
# that when the encrypted value is read back in again it won't cause
# parsing issues.
sub _apply_escape_sequences
{
DBUG_ENTER_FUNC ( @_ );
my $value = shift; # Encrypted ...
my $rOpts = shift;
my ( $lq, $rq ) = _get_encryption_quotes ( $rOpts );
# Strings to use in the regular expressions ...
my ($l_quote, $r_quote) = ( convert_to_regexp_string ($lq, 1),
convert_to_regexp_string ($rq, 1) );
my $cmt = convert_to_regexp_string ($rOpts->{comment}, 1);
my $var = convert_to_regexp_string ($rOpts->{variable_left}, 1);
# ---------------------------------------------------------------
# Replace any problem char for values with escape sequences ...
# ---------------------------------------------------------------
$value =~ s/\\/\\z/sg; # Done so we can use \ as an escape sequence.
$value =~ s/\n/\\n/sg; # Remove embedded "\n" so no mult-lines.
$value =~ s/%/\\p/sg; # So calls to DBUG_PRINT won't barf ...
( run in 1.464 second using v1.01-cache-2.11-cpan-d8267643d1d )