Advanced-Config
view release on metacpan or search on metacpan
lib/Advanced/Config/Reader.pm view on Meta::CPAN
# ==============================================================
# No fish please ... (called way too often)
# This method is called in 2 ways:
# 1) By parse_line() to determine if ${ln} is a tag/value pair.
# 2) By everyone else to parse a known tag/value pair in ${ln}.
#
# ${ln} is in one of these 3 formats if it's a tag/value pair.
# tag = value
# export tag = value # Unix shell scripts
# set tag = value # Windows Batch files
sub _split_assign
{
my $rOpts = shift; # The read options ...
my $ln = shift; # The value to split ...
my $skip = shift; # Skip massaging the tag?
my ( $tag, $value );
if ( is_assign_spaces ( $rOpts ) ) {
( $tag, $value ) = split ( " ", $ln, 2 );
$skip = 1; # This separator doesn't support the prefixes.
} else {
my $assign_str = convert_to_regexp_string ($rOpts->{assign}, 1);
( $tag, $value ) = split ( /\s*${assign_str}\s*/, $ln, 2 );
}
my $export_prefix = "";
unless ( $skip ) {
# Check if one of the export/set variable prefixes were used!
if ( $tag =~ m/^(export\s+)(\S.*)$/i ) {
$tag = $2; # Remove the leading "export" keyword ...
$export_prefix = $1;
} elsif ( $tag =~ m/^(set\s+)(\S.*)$/i ) {
$tag = $2; # Remove the leading "set" keyword ...
$export_prefix = $1;
}
}
# Did we request case insensitive tags ... ?
my $ci_tag = ( $rOpts->{tag_case} && defined $tag ) ? lc ($tag) : $tag;
return ( $ci_tag, $value, $export_prefix, $tag );
}
# ==============================================================
=item $sts = read_config ( $file, $config )
This method performs the reading and parsing of the given config file and puts
the results into the L<Advanced::Config> object I<$config>. This object
provides the necessary parsing rules to use.
If a line was too badly mangled to be parsed, it will be ignored and a warning
will be written to your screen.
It returns B<1> on success and B<0> on failure.
Please note that comments are just thrown away by this process and only
tag/value pairs remain afterwards. Everything else is just instructions to
the parser or how to group together these tag/value pairs.
If it sees something like: export tag = value, it will export tag's value
to the %ENV hash for you just like it does in a Unix shell script!
Additional modifiers can be found in the comments after a tag/value pair
as well.
=cut
# ==============================================================
sub read_config
{
DBUG_ENTER_FUNC ( @_ );
my $file = shift; # The filename to read ...
my $cfg = shift; # The Advanced::Config object ...
my $opts = $cfg->get_cfg_settings (); # The Read Options ...
# Locate the parent section of the config file.
my $pcfg = $cfg->get_section ();
# Using a variable so that we can be recursive in reading config files.
my $READ_CONFIG;
DBUG_PRINT ("INFO", "Opening the config file named: %s", $file);
unless ( open ($READ_CONFIG, "<", $file) ) {
return DBUG_RETURN ( croak_helper ($opts,
"Unable to open the config file.", 0) );
}
# Misuse of this option makes the config file unreadable ...
if ( $opts->{use_utf8} ) {
binmode ($READ_CONFIG, "encoding(UTF-8)");
$pcfg->_allow_utf8 (); # Tells get_date() that wide char languages are OK!
}
# Some common RegExp strings ... Done here to avoid asking repeatably ...
my $decrypt_str = convert_to_regexp_string ($opts->{decrypt_lbl});
my $encrypt_str = convert_to_regexp_string ($opts->{encrypt_lbl});
my $hide_str = convert_to_regexp_string ($opts->{hide_lbl});
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 ) {
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)
lib/Advanced/Config/Reader.pm view on Meta::CPAN
# If balanced quotes were found ...
if ( $q1 ) {
# If the surrounding quotes don't have quotes inside them ...
# IE not malformed ...
unless ( $val2 =~ m/${l_quote}/ || $val2 =~ m/${r_quote}/ ) {
my $cmt2 = convert_to_regexp_string ($cmts);
$cmts =~ s/^\s*${comment}\s*//; # Remove comment symbol ...
$line =~ s/${cmt2}$// if ($cmt2 ne "" ); # Remove the comments ...
DBUG_PRINT ("LINE", "Balanced Quotes encountered for removal ...");
return DBUG_RETURN ( $tv_pair_flag, $line, $cmts, $l_quote, $r_quote);
}
}
}
# The Quotes weren't balanced, so they can no longer be removed from
# arround the value of what's returned!
$l_quote = $r_quote = "";
# ----------------------------------------------------------------------
# If no comments in the line, just return the trimmed string ...
# Both tests are needed due to custom comment/assign strings!
# ----------------------------------------------------------------------
if ( $line !~ m/${comment}/ ) {
DBUG_PRINT ("LINE", "Simply no comments to worry about ...");
return DBUG_RETURN ( $tv_pair_flag, $line, "", "", "" );
}
# Handles case where a comment char embedded in the assignment string.
if ( $tv_pair_flag && $value !~ m/${comment}/ ) {
DBUG_PRINT ("LINE", "Simply no comments in the value to worry about ...");
return DBUG_RETURN ( $tv_pair_flag, $line, "", "", "" );
}
# ----------------------------------------------------------------------
# If not protected by balanced quotes, verify the comment symbol detected
# isn't actually a variable modifier. Variables are allowed in most places
# in the config file, not just in tag/value pairs.
# ----------------------------------------------------------------------
# The left & right anchor points for variable substitution ...
my $lvar = convert_to_regexp_string ($opts->{variable_left}, 1);
my $rvar = convert_to_regexp_string ($opts->{variable_right}, 1);
# Determine what value to use in variable substitutions that doesn't include
# a variable tag, or a comment tag, or a value in the $line.
my $has_no_cmt;
foreach ("A" .. "Z", "@") {
$has_no_cmt = ${_}x10;
last unless ( $has_no_cmt =~ m/${comment}/ ||
$has_no_cmt =~ m/${lvar}/ ||
$has_no_cmt =~ m/${rvar}/ ||
$line =~ m/${has_no_cmt}/ );
}
if ( $has_no_cmt eq "@"x10 ) {
warn ("May be having variable substitution issues in parse_line()!\n");
}
# Strip out all the variables from the value ...
# Assumes processing variables from left to right ...
# Need to evaluate even if variables are disabled to parse correctly ...
my @parts = parse_for_variables ($var_line, 1, $opts);
my $cmt_found = 0;
my $count_var = 0;
my @data;
while (defined $parts[0]) {
$cmt_found = $parts[3];
push (@data, $var_line);
last if ($cmt_found);
$var_line = $parts[0] . $has_no_cmt . $parts[2];
@parts = parse_for_variables ($var_line, 1, $opts);
++$count_var;
}
push (@data, $var_line);
my $unbalanced_leading_var_anchor_with_comments = 0;
if ( $cmt_found && $parts[0] =~ m/(\s*${comment}\s*)(.*$)/ ) {
# parts[1] is parts[7] trimmed ... so join back together with untrimmed.
$cmts = $2 . $opts->{variable_left} . $parts[7]
. $opts->{variable_right} . $parts[2];
my $str = convert_to_regexp_string ( $1 . $cmts );
$line =~ s/${str}$//;
DBUG_PRINT ("LINE", "Variables encountered with variables in comment ...");
return DBUG_RETURN ( $tv_pair_flag, $line, $cmts, "", "");
} elsif ( $count_var ) {
if ( $var_line =~ m/(\s*${comment}\s*)(.*)$/ ) {
$cmts = $2;
if ( $cmts =~ m/${has_no_cmt}/ ) {
$unbalanced_leading_var_anchor_with_comments = 1;
} 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 = "";
}
}
lib/Advanced/Config/Reader.pm view on Meta::CPAN
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
# ==============================================================
sub expand_variables
{
my $config = shift; # For the current section of config obj ...
my $value = shift; # The value to parse for variables ...
my $file = shift || ""; # The config file the value came from ...
my $mask_flag = shift || 0; # Hide/mask sensitive info written to fish?
my $trim_flag = shift || 0; # Tells if we should trim the result or not.
# Only mask ${value} if ${mask_flag} is true ...
DBUG_MASK_NEXT_FUNC_CALL (1) if ( $mask_flag );
DBUG_ENTER_FUNC ( $config, $value, $file, $mask_flag, $trim_flag, @_);
my $opts = $config->get_cfg_settings (); # The Read Options ...
my $pcfg = $config->get_section(); # Get the main/parent section to work with!
# Don't write to Fish if we're hiding any values ...
if ( $mask_flag ) {
DBUG_PAUSE ();
DBUG_MASK ( 0 );
}
# The 1st split of the value into it's component parts ...
my ($left, $tag, $right, $cmt_flag, $mod_tag, $mod_opt, $mod_val, $ot) =
parse_for_variables ( $value, 0, $opts );
# Any variables to substitute ???
unless ( defined $tag ) {
return DBUG_RETURN ( $value, $mask_flag ); # nope ...
}
my $output = $value;
my %encrypt_vars;
my $encrypt_cnt = 0;
my $encrypt_fmt = "_"x50 . "ENCRYPT_%02d" . "-"x50;
my ($lv, $rv) = ( convert_to_regexp_string ($opts->{variable_left}),
convert_to_regexp_string ($opts->{variable_right}) );
# While there are still variables to process ...
while ( defined $tag ) {
my ( $val, $mask );
my $do_mod_lookup = 0; # Very rarely set to true ...
# ${tag} and ${mod_tag} will never have the same value ...
# ${mod_tag} will amost always be undefinded.
# If both are defined, we'll almost always end up using ${mod_tag} as
# the real variable to expand! But we check to be sure 1st.
( $val, $mask ) = $config->lookup_one_variable ( $tag );
# It's extreemly rare to have this "if statement" evalate to true ...
if ( (! defined $val) && defined $mod_tag ) {
( $val, $mask ) = $config->lookup_one_variable ( $mod_tag );
# -----------------------------------------------------------------
# If we're using variable modifiers, it doesn't matter if the
# varible exists or not. The modifier gets evaluated!
# So checking if the undefined $mod_tag needs to be masked or not ...
# -----------------------------------------------------------------
unless ( defined $val ) {
$mask = should_we_hide_sensitive_data ( $mod_tag );
}
$do_mod_lookup = 1; # Yes, apply the modifiers!
}
# Use a place holder if the variable references data that is still encrypted.
if ( $mask == -1 ) {
$mask_flag = -1;
$val = sprintf ($encrypt_fmt, ++$encrypt_cnt);
# If the place holder contains variable anchors abort the substitutions.
last if ( $val =~ m/${lv}/ || $val =~ m/${rv}/ );
$encrypt_vars{$val} = $tag;
$do_mod_lookup = 0;
}
# Doing some accounting to make sure any sensitive data doesn't
# show up in the fish logs from now on.
if ( $mask && ! $mask_flag ) {
$mask_flag = 1;
DBUG_PAUSE ();
DBUG_MASK ( 0 );
}
if ( $do_mod_lookup ) {
my $m;
($val, $m) = apply_modifier ( $config, $val, $mod_tag, $mod_opt, $mod_val, $file );
if ( $m == -2 ) {
# The name of the variable changed & points to an encrypted value.
$val = $opts->{variable_left} . ${val} . $opts->{variable_right};
} elsif ( $m && ! $mask_flag ) {
$mask_flag = 1;
DBUG_PAUSE ();
DBUG_MASK ( 0 );
}
}
lib/Advanced/Config/Reader.pm view on Meta::CPAN
die ($err, "when you've disabled variables while there are quotes in the value as well!\n");
}
}
# Convert the comment symbols to the special variable if no quotes are allowed.
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 );
lib/Advanced/Config/Reader.pm view on Meta::CPAN
++$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 ...
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 );
lib/Advanced/Config/Reader.pm view on Meta::CPAN
}
# --------------------------------------------
# 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} );
}
# ---------------------------------------------------------------
# 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 ...
$value =~ s/${cmt}/\\3/sg; # Don't want any comment chars ...
if ( $rq ) {
( run in 0.840 second using v1.01-cache-2.11-cpan-39bf76dae61 )