Advanced-Config
view release on metacpan or search on metacpan
lib/Advanced/Config/Reader.pm view on Meta::CPAN
# 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 ) {
my $m = "You can't override special variable '${1}'."
. " Ignoring this line in the config file.\n";
if ( $skip_warns_due_to_make_test ) {
DBUG_PRINT ("WARN", $m);
} else {
warn $m;
}
next;
}
# Was the tag's value encryped?? Then we need to decrypt it ...
my $still_encrypted = 0;
if ( $cmt =~ m/(^|${lbl_sep})${decrypt_str}(${lbl_sep}|$)/ ) {
$value = _reverse_escape_sequences ( $value, $opts );
if ( $opts->{disable_decryption} ) {
$still_encrypted = 1; # Doesn't get decrypted.
} else {
$value = decrypt_value ( $value, $t2, $opts, $file );
}
}
# See if we can expand variables in $value ???
my $still_variables = 0;
if ( $opts->{disable_variables} ) {
$still_variables = ( $value =~ m/${lv}.+${rv}/ ) ? 1 : 0;
} elsif ( ! $still_encrypted ) {
($value, $hide) = expand_variables ( $cfg, $value, $file, $hide, ($lq ? 0 : 1) );
if ( $hide == -1 ) {
# $still_encrypted = $still_variables = 1;
$still_variables = 1; # Variable(s) points to encrypted data.
}
}
lib/Advanced/Config/Reader.pm view on Meta::CPAN
} else {
my $cmt2 = convert_to_regexp_string ($1 . $cmts);
$line =~ s/${cmt2}$//;
DBUG_PRINT ("LINE", "Variables encountered with constant comment ...");
}
} else {
$cmts = "";
DBUG_PRINT ("LINE", "Variables encountered without comments ...");
}
unless ( $unbalanced_leading_var_anchor_with_comments ) {
return DBUG_RETURN ( $tv_pair_flag, $line, $cmts, "", "");
}
}
# ---------------------------------------------------------------------------
# Corrupted variable definition with variables in the comments ...
# Boy things are getting difficult to parse. Reverse the previous variable
# substitutions until the all variables in the comments are unexpanded again!
# Does a greedy RegExp to grab the 1st comment string encountered.
# ---------------------------------------------------------------------------
if ( $unbalanced_leading_var_anchor_with_comments ) {
$cmts = "";
foreach my $l (reverse @data) {
if ( $l =~ m/\s*${comment}\s*(.*)$/ ) {
$cmts = $1;
last unless ( $cmts =~ m/${has_no_cmt}/ );
$cmts = "";
}
}
if ( $cmts ne "" ) {
my $cmt2 = convert_to_regexp_string ($cmts);
$line =~ s/\s*${comment}\s*${cmt2}$//;
DBUG_PRINT ("LINE", "Unbalanced var def encountered with var comments ...");
return DBUG_RETURN ( $tv_pair_flag, $line, $cmts, "", "");
}
# If you get here, assume it's not a tag/value pair even if it is!
# I know I can no longer hope to parse it correctly without a test case.
# But I really don't think it's possible to get here anymore ...
warn ("Corrupted variable definition encountered. Can't split out the comment with variables in it correctly!\n");
return DBUG_RETURN ( 0, $line, "", "", "");
}
# ----------------------------------------------------------------------
# No variables, no balanced quotes ...
# But I still think there's a comment to remove!
# ----------------------------------------------------------------------
if ( $tv_pair_flag && $value =~ m/(\s*${comment}\s*)(.*)$/ ) {
$cmts = $2;
my $cmt2 = convert_to_regexp_string ($1 . $cmts);
$line =~ s/${cmt2}$//; # Remove the comment from the line.
DBUG_PRINT ("LINE", "Last ditch effort to remove the comment from the value ...");
return DBUG_RETURN ( $tv_pair_flag, $line, $cmts, "", "");
}
$cmts = $line;
$line =~ s/\s*${comment}.*$//; # Strip off any comments ....
$cmts = substr ( $cmts, length ($line) ); # Grab the comments ...
$cmts =~ s/^\s*${comment}\s*//; # Remove comment symbol ...
DBUG_PRINT ("LINE", "Last ditch effort to remove the comment from the line ...");
DBUG_RETURN ( $tv_pair_flag, $line, $cmts, "", "");
}
# ==============================================================
=item ($v[, $h]) = expand_variables ( $config, $string[, $file[, $sensitive[, trim]]] )
This function takes the provided I<$string> and expands any embedded variables
in this string similar to how it's handled by a Unix shell script.
The optional I<$file> tells which file the string was read in from.
The optional I<$sensitive> when set to a non-zero value is used to disable
B<fish> logging when it's turned on because the I<$string> being passed contains
sensitive information.
The optional I<$trim> tells if you may trim the results before it's returned.
It returns the new value $v, once all the variable substitution(s) have
occurred. And optionally a second return value $h that tells if B<fish> was
paused during the expansion of that value due to something being sensitive.
This 2nd return value $h is meaningless in most situations, so don't ask for it.
All variables are defined as B<${>I<...>B<}>, where I<...> is the variable you
wish to substitute. If something isn't surrounded by a B<${> + B<}> pair, it's
not a variable.
A config file exampe:
tmp1 = /tmp/work-1
tmp2 = /tmp/work-2
opt = 1
date = 2011-02-03
logs = ${tmp${opt}}/log-${date}.txt
date = 2012-12-13
So when passed "${tmp${opt}}/log-${date}.txt", it would return:
/tmp/work-1/log-2011-02-03.txt
And assigned it to B<logs>.
As you can see multiple variable substitutions may be expanded in a single
string as well as nested substitutions. And when the variable substitution is
done while reading in the config file, all the values used were defined before
the tag was referenced.
Should you call this method after the config file was loaded you get slightly
different results. In that case the final tag value is used instead and the
2nd date in the above example would have been used in it's place.
See L<Advanced::Config::lookup_one_variable> for more details on how it
evaluates individual variables.
As a final note, if one or more of the referenced variables holds encrypted
values that haven't yet been decrypted, those variables are not resolved. But
all variables that don't contain encrypted data are resolved.
=cut
lib/Advanced/Config/Reader.pm view on Meta::CPAN
# 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);
DBUG_PRINT ("MOD", "Getting all varriables starting with %s", $mod_val);
} elsif ( $mod_opt eq "!" ) {
($output, $mask) = $cfg->lookup_one_variable ( $alt_val );
if ( $mask == -1 ) {
$mask = -2; # Indirect reference to encrypted value
$output = $alt_val; # Replace with new variable name
} elsif ( $mask ) {
DBUG_MASK (0);
}
DBUG_PRINT ("MOD", "Indirectly referencing variable %s (%s)", $alt_val, $mask);
} elsif ( $mod_opt eq "//" ) {
my ($ptrn, $val) = split ("/", $mod_val);
$output = $alt_val;
$output =~ s/${ptrn}/${val}/g;
DBUG_PRINT ("MOD", "Global replacement in %s", $alt_val);
} elsif ( $mod_opt eq "/" ) {
my ($ptrn, $val) = split ("/", $mod_val);
$output = $alt_val;
$output =~ s/${ptrn}/${val}/;
DBUG_PRINT ("MOD", "1st replacement in %s", $alt_val);
} elsif ( $mod_opt eq ":" ) {
my ($offset, $length) = split (":", $mod_val);
if ( defined $length && $length ne "" ) {
$output = substr ( $alt_val, $offset, $length);
} else {
$output = substr ( $alt_val, $offset);
}
DBUG_PRINT ("MOD", "Substring (%s)", $output);
# The 6 case manipulation modifiers ...
} elsif ( $mod_opt eq "^^" ) {
$output = uc ($alt_val);
DBUG_PRINT ("MOD", "Upshift string (%s)", $output);
} elsif ( $mod_opt eq ",," ) {
$output = lc ($alt_val);
DBUG_PRINT ("MOD", "Downshift string (%s)", $output);
} elsif ( $mod_opt eq "~~" ) {
$output = $alt_val;
$output =~ s/([A-Z])|([a-z])/defined $1 ? lc($1) : uc($2)/gex;
DBUG_PRINT ("MOD", "Reverse case of each char in string (%s)", $output);
} elsif ( $mod_opt eq "^" ) {
$output = ucfirst ($alt_val);
DBUG_PRINT ("MOD", "Upshift 1st char in string (%s)", $output);
} elsif ( $mod_opt eq "," ) {
$output = lcfirst ($alt_val);
DBUG_PRINT ("MOD", "Downshift 1st char in string (%s)", $output);
} elsif ( $mod_opt eq "~" ) {
$output = ucfirst ($alt_val);
$output = lcfirst ($alt_val) if ( $alt_val eq $output );
DBUG_PRINT ("MOD", "Reverse case of 1st char in string (%s)", $output);
} 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>.
lib/Advanced/Config/Reader.pm view on Meta::CPAN
($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}/ );
DBUG_PRINT ("XXXX", "%s ===> %s <=== %s -- %d",
$left, $tag, $right, $cmt_flg);
# We know we found the 1st right hand anchor in the string's value.
# But since variables may be nested, we might not be at the correct
# left hand anchor. But at least we know they're going to balance!
# Check for nested variables ... (trim left side)
while ( $tag =~ m/(^.*)${lvar}(.*?$)/ ) {
my ($l, $t) = ($1, $2);
$left .= $s1 . $l;
$tag = $t;
}
# Strip off leading spaces from the tag's name.
# No tag may have leading spaces in it.
# Defering the stripping of trailing spaces until later on purpose!
$tag =~ s/^\s+//;
# -----------------------------------------------------------
# We have a variable! Now check if there are modifiers
# in it that we are supporting ...
# See: http://wiki.bash-hackers.org/syntax/pe
# -----------------------------------------------------------
# The variable modifier tags. Needed to avoid using the wrong rule.
# A variable name can use anything except for what's in this list!
my $not = "[^-:?+#%/\^,~]";
if ( $lvar eq $rvar ) {
; # No modifiers are supported if the left/right anchors are the same!
# Since there are too many modifier/anchor pairs that no longer
# work. Behaving more like a Windows *.bat file now.
} elsif ( $opts->{disable_variable_modifiers} ) {
; # Explicitly told not to use this feature.
# Rule: :-, :=, :+, -, =, or +
} elsif ( $tag =~ m/(^${not}+)(:?[-=+])(.+)$/) {
($sub_tag, $sub_opr, $sub_val) = ($1, $2, $3);
# Rule: :? or ?
} elsif ( $tag =~ m/(^${not}+)(:?[?])(.*)$/) {
($sub_tag, $sub_opr, $sub_val) = ($1, $2, $3);
$sub_val = "Parameter null or not set." if ( $sub_val eq "" );
# Rule: ##, %%, #, or %
} elsif ( $tag =~ m/^(${not}+)(##)(.+)$/ ||
$tag =~ m/^(${not}+)(%%)(.+)$/ ||
$tag =~ m/^(${not}+)(#)(.+)$/ ||
$tag =~ m/^(${not}+)(%)(.+)$/ ) {
($sub_tag, $sub_opr, $sub_val) = ($1, $2, $3);
# Rule: Get length of variable's value ...
} elsif ( $tag =~ m/^#(.+)$/ ) {
# Using LENGTH for ${#var} opt since "#" is already used above!
($sub_tag, $sub_opr, $sub_val) = ($1, "LENGTH", "");
$sub_tag =~ s/^\s+//;
# Rule: ${!var*} & ${!var@} ...
} elsif ( $tag =~ m/^!(.+)[@*]$/ ) {
# Using LIST for ${!var*} & ${!var@} opts since "!" has another meaning.
($sub_tag, $sub_opr, $sub_val) = ($1, "LIST", convert_to_regexp_string ($1));
$sub_tag =~ s/^\s+//;
# Rule: Indirect lookup ...
} elsif ( $tag =~ m/^!(.+)$/ ) {
($sub_tag, $sub_opr, $sub_val) = ($1, "!", "");
$sub_tag =~ s/^\s+//;
# Rule: Substitution logic ... ( / vs // )
# Anchors # or % supported but no RegExp wildcards are.
} elsif ( $tag =~ m#^(${not}+)(//?)([^/]+)/([^/]*)$# ) {
($sub_tag, $sub_opr, $sub_val, $sub_extra) = ($1, $2, $3, $4);
$sub_val = convert_to_regexp_string ($sub_val);
if ( $sub_val =~ m/^([#%])(.+)$/ ) {
$sub_val = $2;
$sub_val = ( $1 eq "#" ) ? "^${sub_val}/${sub_extra}" : "${sub_val}\$/${sub_extra}";
} else {
$sub_val = "${sub_val}/${sub_extra}";
}
$sub_val .= "/x";
# Rule: Another format for the Substitution logic ... ( / vs // )
} elsif ( $tag =~ m#^(${not}+)(//?)([^/]+)$# ) {
($sub_tag, $sub_opr, $sub_val, $sub_extra) = ($1, $2, $3, "");
$sub_val = convert_to_regexp_string ($sub_val);
if ( $sub_val =~ m/^([#%])(.+)$/ ) {
$sub_val = $2;
$sub_val = ( $1 eq "#" ) ? "^${sub_val}/${sub_extra}" : "${sub_val}\$/${sub_extra}";
} else {
$sub_val = "${sub_val}/${sub_extra}";
}
$sub_val .= "/x";
# Rule: Substring expansion ... ${MSG:OFFSET}
} elsif ( $tag =~ m#^(${not}+):([0-9]+)$# ||
$tag =~ m#^(${not}+):\s+(-[0-9]+)$# ||
$tag =~ m#^(${not}+):[(](-[0-9]+)[)]$# ) {
($sub_tag, $sub_opr, $sub_val) = ($1, ":", $2);
$sub_val .= ":"; # To the end of the string ...
# Rule: Substring expansion ... ${MSG:OFFSET:LENGTH}
} elsif ( $tag =~ m#^(${not}+):([0-9]+):(-?[0-9]+)$# ||
$tag =~ m#^(${not}+):\s+(-[0-9]+):(-?[0-9]+)$# ||
$tag =~ m#^(${not}+):[(](-[0-9]+)[)]:(-?[0-9]+)$# ) {
($sub_tag, $sub_opr, $sub_val, $sub_extra) = ($1, ":", $2, $3);
$sub_val .= ":${sub_extra}";
# Rule: Case manipulation ... (6 variants)
} elsif ( $tag =~ m/^(${not}+)([\^]{1,2})$/ ||
$tag =~ m/^(${not}+)([,]{1,2})$/ ||
lib/Advanced/Config/Reader.pm view on Meta::CPAN
if ( $new_value =~ m/${rlq2}/ || $new_value =~ m/${rrq2}/ ) {
$nlq = $nrq = ""; # Balanced quotes are not supported for this value!
}
}
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 $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
lib/Advanced/Config/Reader.pm view on Meta::CPAN
my ( $lq, $rq ) = _get_encryption_quotes ( $rOpts );
my $cmt = $rOpts->{comment};
my $var = $rOpts->{variable_left};
# Strings to use in the regular expressions ... (by caller)
my ($l_quote, $r_quote) = ( convert_to_regexp_string ($lq, 1),
convert_to_regexp_string ($rq, 1) );
# ---------------------------------------------------------------
# Replace the escape sequences to get back the problem chars ...
# Done in reverse order of what was done in: _apply_escape_sequences()!
# ---------------------------------------------------------------
$value =~ s/\\0/\0/sg;
$value =~ s/\\v/${var}/sg;
if ( $rq ) {
$value =~ s/\\Q/${rq}/sg;
$value =~ s/\\q/${lq}/sg;
}
$value =~ s/\\3/${cmt}/sg;
$value =~ s/\\p/%/sg;
$value =~ s/\\n/\n/sg;
$value =~ s/\\z/\\/sg;
DBUG_RETURN ( $value, $lq, $rq, $l_quote, $r_quote );
}
# ==============================================================
sub _get_encryption_quotes
{
my $rOpts = shift;
my ($lq, $rq) = ("", "");
if ( using_default_quotes ( $rOpts ) ) {
$lq = $rq = "'"; # Chooses ' over " ...
} elsif ( ! $rOpts->{disable_quotes} ) {
($lq, $rq) = ( $rOpts->{quote_left}, $rOpts->{quote_right} );
}
return ( $lq, $rq );
}
# ==============================================================
# USAGE: $val = _encrypt ($value, $pass_code, $tag, $alias, $usr_flg)
#
# Both encrypts & decrypts the value ...
sub _encrypt
{
DBUG_MASK_NEXT_FUNC_CALL (0, 1); # Masks ${val} & ${pass} ...
DBUG_ENTER_FUNC ( @_ );
my $val = shift; # Sensitive ... if not already encrypted.
my $pass = shift; # Very, very sensitive ... always clear text.
my $tag = shift;
my $alias = shift;
my $usr_flg = shift; # 0 - no, 1 - yes
DBUG_MASK (0);
# Verify lengths are different to prevent repeatable patterns.
if ( length ( $tag ) == length ( $alias ) ) {
$tag .= "|"; # Make different lengths
}
my $len = length ( $val );
my $key1 = _make_key ( $tag, $len );
my $key2 = _make_key ( $alias, $len );
my $res = $key1 ^ $key2;
if ( $pass ) {
my $key3 = _make_key ( $pass, $len );
$res = $res ^ $key3;
}
if ( $usr_flg ) {
my $key4 = _make_key ( $gUserName, $len );
$res = $res ^ $key4;
}
unless ( $val =~ m/[^\x00-\xff]/ ) {
$res = $res ^ $val; # ascii ...
} else {
# Unicode version of ($res ^ $val) ...
$res = _bitwise_exclusive_or ( $res, $val );
}
DBUG_RETURN ( $res ); # Sometimes encrypted and other times not!
}
# ==============================================================
sub _bitwise_exclusive_or
{
DBUG_ENTER_FUNC (); # Dropped @_ on purpose, always sensitive
my $mask = shift;
my $unicode = shift;
DBUG_MASK (0);
my @m = unpack ("C*", $mask);
my @u = unpack ("U*", $unicode);
my @ans;
foreach ( 0..$#u ) {
$ans[$_] = $m[$_] ^ $u[$_]; # Exclusive or of 2 integers still supported.
}
DBUG_RETURN ( pack ("U*", @ans) );
}
# ==============================================================
# USAGE: $key = _make_key ($target, $len);
sub _make_key
{
DBUG_MASK_NEXT_FUNC_CALL (0); # Masks ${target} ...
DBUG_ENTER_FUNC ( @_ );
my $target = shift; # May be ascii or unicode ...
my $len = shift;
DBUG_MASK (0);
my $phrase;
unless ( $target =~ m/[^\x00-\xff]/ ) {
# Normal text ... (ascii)
$phrase = $target . pack ("C*", reverse (unpack ("C*", $target)));
} else {
# Unicode strings (utf8 / Wide Chars)
# Strip off the upper byte from each unicode char ...
my @ans = map { $_ % 0x100 } unpack ("U*", $target);
$phrase = pack ("C*", @ans) . pack ("C*", reverse (@ans));
}
my $key = $phrase;
while ( length ( $key ) < $len ) {
$key .= $phrase;
}
$key = substr ( $key, 0, $len ); # Truncate it to fit ...
DBUG_RETURN ( $key ); # Always an ascii string ...
}
# ==============================================================
=back
=head1 COPYRIGHT
Copyright (c) 2007 - 2026 Curtis Leach. All rights reserved.
This program is free software. You can redistribute it and/or modify it under
the same terms as Perl itself.
=head1 SEE ALSO
L<Advanced::Config> - The main user of this module. It defines the Config object.
L<Advanced::Config::Options> - Handles the configuration of the Config module.
L<Advanced::Config::Date> - Handles date parsing for get_date().
L<Advanced::Config::Examples> - Provides some sample config files and commentary.
=cut
# ==============================================================
#required if module is included w/ require command;
1;
( run in 0.591 second using v1.01-cache-2.11-cpan-39bf76dae61 )