Skip to content

Commit

Permalink
Handle string escapes just like Perl.
Browse files Browse the repository at this point in the history
  • Loading branch information
@sciurius
sciurius committed Sep 8, 2020
1 parent f79f2cd commit d014d6c
Show file tree
Hide file tree
Showing 4 changed files with 232 additions and 12 deletions.
3 changes: 3 additions & 0 deletions Changes
View file
Expand Up @@ -2,6 +2,9 @@ Revision history for Data-Properties

1.01
Make ${foo:bar} work.
Add 'null' and testing for it.
Add arrays and data() export.
Handle string escapes just like Perl.

1.00 2020-09-05
First version, released on an unsuspecting world.
Expand Down
124 changes: 112 additions & 12 deletions lib/Data/Properties.pm
View file
Expand Up @@ -8,8 +8,8 @@ use warnings;
# Author : Johan Vromans
# Created On : Mon Mar 4 11:51:54 2002
# Last Modified By: Johan Vromans
# Last Modified On: Tue Sep 8 09:43:29 2020
# Update Count : 370
# Last Modified On: Tue Sep 8 21:22:51 2020
# Update Count : 419
# Status : Unknown, Use with caution!

=head1 NAME
Expand Down Expand Up @@ -293,7 +293,7 @@ sub _parse_lines_internal {
# foo.bar = "blech"
# foo.bar = 'blech'
# Simple assignment. The value is expanded unless single quotes are used.
if ( /^\s*([\w.]+)\s*[=:]\s*(.*)/ ) {
if ( /^\s*([-\w.]+)\s*[=:]\s*(.*)/ ) {
my $prop = $1;
my $value = $2;
$value =~ s/\s+$//;
Expand All @@ -305,12 +305,26 @@ sub _parse_lines_internal {
# Handle strings.
if ( $value =~ /^'(.*)'\s*$/ ) {
$value = $1;
$value =~ s/\\\\/\x{fdd0}/g;
$value =~ s/\\'/'/g;
$value =~ s/\x{fdd0}/\\/g;
}
elsif ( lc($value) eq "null" ) {
$value = undef;
}
elsif ( $value =~ /^"(.*)"\s*$/ ) {
$value = $1;
$value =~ s/\\\\/\x{fdd0}/g;
$value =~ s/\\"/"/g;
$value =~ s/\\n/\n/g;
$value =~ s/\\t/\t/g;
$value =~ s/\\([0-7]{1,3})/sprintf("%c",oct($1))/ge;
$value =~ s/\\x([0-9a-f][0-9a-f]?)/sprintf("%c",hex($1))/ge;
$value =~ s/\\x\{([0-9a-f]+)\}/sprintf("%c",hex($1))/ge;
$value =~ s/\x{fdd0}/\\/g;
$value = $self->expand($value, $stack->[0]);
}
else {
$value = $1 if $value =~ /^"(.*)"\s*$/;
$value = $self->expand($value, $stack->[0]);
}

Expand Down Expand Up @@ -514,7 +528,7 @@ sub set_property {
my ($self, $prop, $value) = @_;
my $props = $self->{_props};
$props->{lc($prop)} = $value;
my @prop = split(/\./, $prop);
my @prop = split(/\./, $prop, -1);
while ( @prop ) {
my $last = pop(@prop);
my $p = lc(join(".", @prop, '@'));
Expand Down Expand Up @@ -581,12 +595,71 @@ sub result_in_context {
$self->{_in_context};
}

=item data [ I<start> ]
Produces a Perl data structure created from all the properties from a
given point in the hierarchy.
Note that since Perl hashes do not have an ordering, this information
will get lost.
=cut

sub data {
my ($self, $start) = ( @_, '' );
my $ret = $self->_data_internal($start);
$ret;
}

sub _data_internal {
my ( $self, $orig ) = @_;
my $cur = $orig // '';
$cur .= "." if $cur ne '';
my $all = $cur;
$all .= '@';
if ( my $res = $self->{_props}->{lc($all)} ) {
if ( _check_array($res) ) {
my $ret = [];
foreach my $prop ( @$res ) {
$ret->[$prop] = $self->_data_internal($cur.$prop);
}
return $ret;
}
else {
my $ret = {};
foreach my $prop ( @$res ) {
$ret->{$prop} = $self->_data_internal($cur.$prop);
}
return $ret;
}
}
else {
my $val = $self->{_props}->{lc($orig)};
$val = $self->expand($val) if defined $val;
return $val;
}
}

sub _check_array {
my ( $i ) = @_;
my @i = @$i;
return unless "@i" =~ /^[\d ]+$/; # quick
my $ref = 0;
for ( @i) {
return unless $_ eq "$ref";
$ref++;
}
return 1; # success!
}

=item dump [ I<start> [ , I<stream> ] ]
Produce a listing of all properties from a given point in the
Produces a listing of all properties from a given point in the
hierarchy and write it to the I<stream>.
I<stream> defaults to C<*STDOUT>.
Without I<stream>, returns a string.
In general, I<stream> should be UTF-8 capable.
=item dumpx [ I<start> [ , I<stream> ] ]
Expand All @@ -598,7 +671,7 @@ my $dump_expanded;

sub dump {
my ($self, $start, $fh) = ( @_, '' );
my $ret = $self->_dump_internal($fh, $start);
my $ret = $self->_dump_internal($start);
print $fh $ret if $fh;
$ret;
}
Expand All @@ -614,15 +687,15 @@ sub dumpx {
# internal

sub _dump_internal {
my ($self, $fh, $cur) = @_;
my ($self, $cur) = @_;
$cur .= "." if $cur;
my $all = $cur;
$all .= '@';
my $ret = "";
if ( my $res = $self->{_props}->{lc($all)} ) {
$ret .= "# $all = @$res\n" if @$res > 1;
foreach my $prop ( @$res ) {
$ret .= $self->_dump_internal($fh, $cur.$prop);
$ret .= $self->_dump_internal($cur.$prop);
my $val = $self->{_props}->{lc($cur.$prop)};
$val = $self->expand($val) if $dump_expanded;
next unless defined $val;
Expand All @@ -633,6 +706,7 @@ sub _dump_internal {
$ret;
}


################ Package End ################

1;
Expand Down Expand Up @@ -662,8 +736,17 @@ Property I<names> consist of one or more identifiers (series of
letters and digits) separated by periods.
Valid values are a plain text (whitespace, but not trailing, allowed),
a single-quoted string, or a double-quoted string (which will allow
escape characters like \n and so in a future version).
a single-quoted string, or a double-quoted string. Single-quoted
strings allow embedded single-quotes by escaping them with a backslash
C<\>. Double-quoted strings allow common escapes like C<\n>, C<\t>,
C<\7>, C<\x1f> and C<\x{20cd}>.
Note that in plain text backslashes are taken literally. The following
alternatives yield the same results:
foo = a'\nb
foo = 'a\'\nb'
foo = "a'\\nb"
B<IMPORTANT:> All values are strings. There is no distinction between
Expand Down Expand Up @@ -696,6 +779,23 @@ grouped in a I<context>:
Contexts may be nested.
=head2 Arrays
When a property has a number of sub-properties with keys that are
consecutive numbers starting at C<0>, it may be considered as an
array. This is only relevant when using the data() method to retrieve
a Perl data structure from the set of properties.
list {
0 = aap
1 = noot
2 = mies
}
When retrieved using data(), this returns the Perl structure
[ "aap", "noot", "mies" ]
=head2 Includes
Property files can include other property files:
Expand Down
45 changes: 45 additions & 0 deletions t/14-data.t
View file
@@ -0,0 +1,45 @@
#! perl

use Test::More tests => 1;
use Data::Properties;
use utf8;
my $cfg = Data::Properties->new;

$cfg->parse_lines( [ split( /[\r\n]+/, <<EOD ) ], '', 'base' );
version = 1
config.version = 2
nested {
version = 3
something = 4
}
# This is how to make an array
list {
0 {
beest = aap
}
1 = noot♩
2 = mies
}
EOD

is_deeply( $cfg->data,
{ base => {
config => {
version => 2,
},
list => [
{
beest => 'aap',
},
"noot\x{2669}",
'mies',
],
nested => {
something => 4,
version => 3,
},
version => 1,
},
}
);
72 changes: 72 additions & 0 deletions t/15-escape.t
View file
@@ -0,0 +1,72 @@
#! perl

use Test::More tests => 3;
use Data::Properties;
use utf8;
my $cfg;

$cfg = Data::Properties->new;
$cfg->parse_lines( [ split( /[\r\n]+/, <<'EOD' ) ] );
a = "aa\nbb"
b = "aa\\nbb"
c = "aa\\\nbb"
d = "aa\\\\nbb"
e = "aa\\\\\nbb"
EOD

is_deeply( $cfg->data,
{ a => "aa\nbb",
b => "aa\\nbb",
c => "aa\\\nbb",
d => "aa\\\\nbb",
e => "aa\\\\\nbb",
}
);

$cfg = Data::Properties->new;
$cfg->parse_lines( [ split( /[\r\n]+/, <<'EOD' ) ] );
a0 = aa\07bb
a1 = "aa\07bb"
a2 = "aa\1bb"
a3 = "aa\11bb"
a4 = "aa\111bb"
a5 = "aa\1111bb"
a6 = "aa\01111bb"
b = "aa\x9bb"
c = "aa\x{20ce}bb"
EOD

is_deeply( $cfg->data,
{ a0 => "aa\\07bb",
a1 => "aa\07bb",
a2 => "aa\1bb",
a3 => "aa\11bb",
a4 => "aa\111bb",
a5 => "aa\1111bb",
a6 => "aa\01111bb",
b => "aa\x9bb",
c => "aa\x{20ce}bb",
}
);

$cfg = Data::Properties->new;
$cfg->parse_lines( [ split( /[\r\n]+/, <<'EOD' ) ] );
a0 = aa'bb
a1 = aa\bb
a2 = 'aa\'bb'
a3 = 'aa\\bb'
f1 = a'\nb
f2 = 'a\'\nb'
f3 = "a'\\nb"
EOD

is_deeply( $cfg->data,
{ a0 => "aa'bb",
a1 => 'aa\\bb',
a2 => "aa'bb",
a3 => 'aa\\bb',
f1 => 'a\'\nb',
f2 => 'a\'\nb',
f3 => 'a\'\nb',
}
);

0 comments on commit d014d6c

Please sign in to comment.