Advanced-Config
view release on metacpan or search on metacpan
lib/Advanced/Config/Reader.pm view on Meta::CPAN
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)
}
# User defined quotes ...
} else {
my $q = convert_to_regexp_string ($opts->{quote_left}, 1);
if ( $value =~ m/^(${q})/ ) {
$l_quote = $q;
$r_quote = convert_to_regexp_string ($opts->{quote_right}, 1);
}
}
$var_line = $value;
}
# Comment still in value, but still haven't proved any quotes are balanced.
DBUG_PRINT ("DEBUG", "Tag (%s), Value (%s), Proposed Left (%s), Right (%s)",
$tag, $value, $l_quote, $r_quote);
my $cmts = "";
# Was the value in the tag/value pair starting with a left quote?
if ( $tv_pair_flag && $l_quote ne "" ) {
my ($q1, $val2, $q2);
# Now check if they were balanced ...
if ( $value =~ m/^(${l_quote})(.*)(${r_quote})(\s*${comment}.*$)/ ) {
($q1, $val2, $q2, $cmts) = ($1, $2, $3, $4); # Has a comment ...
} elsif ( $value =~ m/^(${l_quote})(.*)(${r_quote})\s*$/ ) {
($q1, $val2, $q2, $cmts) = ($1, $2, $3, ""); # Has no comment ...
}
# 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 ...
lib/Advanced/Config/Reader.pm view on Meta::CPAN
$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})$/ ||
$tag =~ m/^(${not}+)([~]{1,2})$/ ) {
($sub_tag, $sub_opr, $sub_val) = ($1, $2, "");
} else {
; # No variable modifiers were found!
}
# Strip off any trailing spaces from the tag & sub-tag names ...
$tag =~ s/\s+$//;
$sub_tag =~ s/\s+$// if ( defined $sub_tag );
} # End "if" a tag/variable was found in ${value} ...
# Are we using case insensitive tags/variables?
# If so, all varibles must be in lower case ...
# Leave $otag alone.
if ( $opts->{tag_case} ) {
$tag = lc ($tag) if ( defined $tag );
$sub_tag = lc ($sub_tag) if ( defined $sub_tag );
}
DBUG_RETURN ( $left, $tag, $right, $cmt_flg, $sub_tag, $sub_opr, $sub_val,
$otag );
}
# ==============================================================
=item $string = format_section_line ( $name, \%rOpts )
Uses the given I<Read Options Hash> to generate a section string
from I<$name>.
=cut
sub format_section_line
{
DBUG_ENTER_FUNC ( @_ );
my $name = shift; # The name of the section ...
my $rOpts = shift;
DBUG_RETURN ( $rOpts->{section_left} . " ${name} " . $rOpts->{section_right} );
}
# ==============================================================
=item $string = format_tag_value_line ( $cfg, $tag, \%rOpts )
It looks up the B<tag> in the I<$cfg> object, then it uses the given
I<Read Options Hash> options to format a tag/value pair string.
=cut
sub format_tag_value_line
{
DBUG_ENTER_FUNC ( @_ );
my $cfg = shift; # An Advanced::Config object reference.
my $tag = shift;
my $rOpts = shift;
my ($value, $sensitive) = $cfg->_base_get2 ( $tag, {required => 1} );
DBUG_MASK (0) if ( $sensitive );
# Determine if we're alowed to surround things with quotes ...
my ($quote_l, $quote_r); # Assume no!
if (using_default_quotes ( $rOpts )) {
if ( $value =~ m/'/ && $value =~ m/"/ ) {
my $noop; # No quotes allowed!
} elsif ( $value !~ m/'/ ) {
$quote_l = $quote_r = "'";
} elsif ( $value !~ m/"/ ) {
$quote_l = $quote_r = '"';
}
} elsif ( ! $rOpts->{disable_quotes} ) {
my ($ql, $qr) = ( convert_to_regexp_string ($rOpts->{quote_left}, 1),
convert_to_regexp_string ($rOpts->{quote_right}, 1) );
unless ( $value =~ m/${ql}/ || $value =~ m/${qr}/ ) {
$quote_l = $rOpts->{quote_left};
$quote_r = $rOpts->{quote_right};
}
}
# Do we have to correct for having comments in the value?
my $cmt = convert_to_regexp_string ($rOpts->{comment}, 1);
if ( $value =~ m/${cmt}/ ) {
my $err = "Can't do toString() due to using comments in the value of '${tag}'\n";
if ( $rOpts->{disable_variables} ) {
if ( $rOpts->{disable_quotes} ) {
die ($err, "when you've also disabled both quotes & variables!\n");
}
unless ( $quote_l ) {
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};
}
lib/Advanced/Config/Reader.pm view on Meta::CPAN
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 );
}
( run in 2.376 seconds using v1.01-cache-2.11-cpan-483215c6ad5 )