Advanced-Config
view release on metacpan or search on metacpan
lib/Advanced/Config/Reader.pm view on Meta::CPAN
# 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.
}
}
# Export one value to %ENV ... (once set, can't back it out again!)
$cfg->export_tag_value_to_ENV ( $tag, $value, $hide ) if ($export_flag);
# Add to the current section in the Advanced::Config object ...
$cfg->_base_set ($tag, $value, $file, $hide, $still_encrypted, $still_variables);
} # End while reading the config file ...
close ( $READ_CONFIG );
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!
lib/Advanced/Config/Reader.pm view on Meta::CPAN
$hide = 1;
}
}
# Is it a section whose contents we need to hide???
} elsif ( $ln =~ m/^${lb}\s*(.+?)\s*${rb}$/ ) {
my $section = lc ($1);
$hide_section = should_we_hide_sensitive_data ( $section, 1 ) ? 1 : 0;
}
unless ( $hide ) {
DBUG_PRINT ("ENCRYPT", $line);
unless (print NEW $line, "\n") {
return DBUG_RETURN ( croak_helper ($rOpts, $errMsg, 0) );
}
next;
}
# ------------------------------------------------
# Only Tag/Value pairs get this far ...
# Either needs to be encrypted, hidden, or both.
# ------------------------------------------------
my $ass = ( is_assign_spaces ( $rOpts ) ) ? "" : $rOpts->{assign};
if ( $cmt ) {
DBUG_PRINT ("ENCRYPT", "%s%s %s %s %s %s",
$prefix, $tag, $ass, $mask, $rOpts->{comment}, $cmt);
} else {
DBUG_PRINT ("ENCRYPT", "%s%s %s %s", $prefix, $tag, $ass, $mask);
}
unless ( $encrypt ) {
unless (print NEW $line, "\n") {
return DBUG_RETURN ( croak_helper ($rOpts, $errMsg, 0) );
}
next;
}
# --------------------------------------------
# Now let's encrypt the Tag/Value pair ...
# --------------------------------------------
++$count;
# Save the values we need to change safe to use as RegExp strings.
my $old_cmt = convert_to_regexp_string ( $cmt, 1 );
my $old_value = convert_to_regexp_string ( $value, 1 );
# 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 ...
lib/Advanced/Config/Reader.pm view on Meta::CPAN
$hide = 1;
}
}
# Is it a section whose contents we need to hide???
} elsif ( $ln =~ m/^${lb}\s*(.+?)\s*${rb}$/ ) {
my $section = lc ($1);
$hide_section = should_we_hide_sensitive_data ( $section, 1 ) ? 1 : 0;
}
unless ( $hide ) {
DBUG_PRINT ("DECRYPT", $line);
unless (print NEW $line, "\n") {
return DBUG_RETURN ( croak_helper ($rOpts, $errMsg, 0) );
}
next;
}
# ------------------------------------------------
# Only Tag/Value pairs get this far ...
# Either needs to be decrypted, hidden, or both.
# ------------------------------------------------
my $ass = ( is_assign_spaces ( $rOpts ) ) ? "" : $rOpts->{assign};
if ( $decrypt ) {
DBUG_PRINT ("DECRYPT", $line);
} elsif ( $cmt ) {
DBUG_PRINT ("DECRYPT", "%s%s %s %s %s %s",
$prefix, $tag, $ass, $mask, $rOpts->{comment}, $cmt);
} else {
DBUG_PRINT ("DECRYPT", "%s%s %s %s", $prefix, $tag, $ass, $mask);
}
unless ( $decrypt ) {
unless (print NEW $line, "\n") {
return DBUG_RETURN ( croak_helper ($rOpts, $errMsg, 0) );
}
next;
}
# --------------------------------------------
# Now let's decrypt the tag/value pair ...
# --------------------------------------------
++$count;
# Save the values we need to change safe to use as RegExp strings.
my $old_cmt = convert_to_regexp_string ( $cmt, 1 );
my $old_value = convert_to_regexp_string ( $value, 1 );
# Modify the label in the comment ...
my $lbl = $rOpts->{encrypt_lbl};
$cmt =~ s/(^|${lbl_sep})${decrypt_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, $rlq2, $rrq2) = _reverse_escape_sequences ( $value, $rOpts );
$new_value = decrypt_value ( $new_value, $t2, $rOpts, $file);
if ( $nlq ) {
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} );
}
lib/Advanced/Config/Reader.pm view on Meta::CPAN
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 ...
$value =~ s/${cmt}/\\3/sg; # Don't want any comment chars ...
if ( $rq ) {
$value =~ s/${l_quote}/\\q/sg;
$value =~ s/${r_quote}/\\Q/sg;
}
$value =~ s/${var}/\\v/sg; # So nothing looks like a variable ...
$value =~ s/\0/\\0/sg; # So no embedded null chars ...
DBUG_RETURN ( $value, $lq, $rq );
}
# ==============================================================
# When an encrypted value is read in from the config file, all escape
# secuences need to be removed before the value can be decrypted.
# These escape sequences were required to avoid parsing issues when
# handling encrypted values.
sub _reverse_escape_sequences
{
DBUG_ENTER_FUNC ( @_ );
my $value = shift; # Encrypted with escape sequences ...
my $rOpts = shift;
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 ) {
( run in 0.492 second using v1.01-cache-2.11-cpan-39bf76dae61 )