Advanced-Config
view release on metacpan or search on metacpan
lib/Advanced/Config/Reader.pm view on Meta::CPAN
$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 ) ) {
lib/Advanced/Config/Reader.pm view on Meta::CPAN
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 ) {
($tag, $value, $prefix, $t2) = _split_assign ( $rOpts, $ln );
if ( $cmt =~ m/(^|${lbl_sep})${encrypt_str}(${lbl_sep}|$)/ ) {
($hide, $encrypt) = (1, 1);
# Don't hide the decrypt string ... (already unreadable)
} elsif ( $cmt =~ m/(^|${lbl_sep})${hide_str}(${lbl_sep}|$)/ ) {
$hide = 1;
} else {
if ( $hide_section || should_we_hide_sensitive_data ( $tag, 1 ) ) {
$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") {
lib/Advanced/Config/Reader.pm view on Meta::CPAN
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 ) {
($tag, $value, $prefix, $t2) = _split_assign ( $rOpts, $ln );
if ( $cmt =~ m/(^|${lbl_sep})${decrypt_str}(${lbl_sep}|$)/ ) {
($hide, $decrypt) = (1, 1);
} elsif ( $cmt =~ m/(^|${lbl_sep})${encrypt_str}(${lbl_sep}|$)/ ||
$cmt =~ m/(^|${lbl_sep})${hide_str}(${lbl_sep}|$)/ ) {
$hide = 1;
} else {
if ( $hide_section || should_we_hide_sensitive_data ( $tag, 1 ) ) {
$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);
}
( run in 1.118 second using v1.01-cache-2.11-cpan-39bf76dae61 )