这是使用Marpa::R2和重载对象的解决方案。结果比预期的要长，但看起来往返兼容。
标题很简单：
use strict; use warnings; use feature 'say';
use Marpa::R2;
use constant DEBUG => 0;
exit main();
这将需要 Perl5 版本 10 或更高版本。接下来是parse子程序。这将进行标记化，并调用解析器。大多数标记被指定为数据（不是显式代码），因此可以轻松扩展它们。
这$print_diag是一个匿名子。它关闭$string和$last_pos，因此可以打印类似于 的适当错误消息die。它将用HERE-->箭头指出标记化问题的上下文。
$matchif 类似的闭包。它遍历所有可用的令牌并返回匹配的令牌，或者失败时返回错误值。它使用m/\G.../gc正则表达式。这些类似于s/^...//，但不会破坏字符串。\G断言将在pos($string). 该/c选项确保失败不会改变pos。
字符串标记是手动匹配的。您可能想要处理转义。我添加了对一些流行的转义符（\\、\"、\n和\t换行反斜杠）的支持。
该TOKEN循环提取令牌并将它们塞入识别器中。它包括很少的代码和很多错误处理。
最后，我们取第一个可能的$parse树（可能有多个），并检查它是否成功。如果是，我们返回数据结构：
my $grammar; # filled later in INIT block
sub parse {
my ($string) = @_;
my ($last_pos, $length) = (0, length $string);
my $rec = Marpa::R2::Recognizer->new({ grammar => $grammar });
my $print_diag = sub {
my ($problem) = @_;
my ($behind, $ahead) = (15, 30);
my $start = $last_pos > $behind ? $last_pos - $behind : 0;
say STDERR "$problem at ", map ">>$_<<", join " HERE-->",
substr($string, $start, $behind),
substr($string, $last_pos, $ahead );
exit 1;
};
my @capture_token = (
[qr/true|false/ => 'Bool'], # bool must come before ident
[qr/-?\d+(?:\.\d+)?/=> 'Number'], # number must come before ident
[qr/\w+/ => 'Ident'],
);
my @non_capture_token = (
[qr/\{/ => 'LCurly'],
[qr/\}/ => 'RCurly'],
[qr/=/ => 'Equal'],
[qr/,/ => 'Comma'],
);
my $match = sub {
# try String manually here:
if ($string =~ m/\G"( (?: [^"]++ | \\. )*+ )"/gcxs) {
my $str = $1;
my %escapes = ( n => "\n", t => "\t", "\n" => '' );
$str =~ s{\\(.)}{ $escapes{$1} // $1 }esg;
return String => $str;
}
for (@non_capture_token) {
my ($re, $type) = @$_;
return $type if $string =~ m/\G$re/gc;
}
for (@capture_token) {
my ($re, $type) = @$_;
return $type, $1 if $string =~ m/\G($re)/gc;
}
return;
};
pos $string = $last_pos; # set match start for \G assertion to beginning
TOKEN: while ($last_pos < $length) {
next TOKEN if $string =~ m/\G\s+/gc;
next TOKEN if $string =~ m/\G\#\N+/gc; # skip comments if you have such
if (my @token = $match->()) {
say STDERR "Token [@token]" if DEBUG;
my $ok = $rec->read(@token);
unless (defined $ok) {
$print_diag->("Token [@token] rejected");
}
} else {
$print_diag->("Can't understand input");
}
} continue {
$last_pos = pos $string;
}
my $parse = $rec->value;
unless ($parse) {
say STDERR "Could not parse input";
say STDERR "The Progress so far:";
say STDERR $rec->show_progress;
exit 1;
}
return $$parse;
}
现在我们指定语法。Marpa 可以通过我在这里使用的类似 BNF 的符号来处理。它主要是低级方法之上的语法糖。我可以指定动作（我稍后会写），并且可以决定不通过将令牌放入括号中来捕获它们。在这个阶段，我只能处理令牌类型，而不是令牌的值。指定语法后，我必须使用$grammar->precompute.
INIT {
$grammar = Marpa::R2::Grammar->new({
actions => "MyActions", # a package name
default_action => 'first_arg',
source => \(<<'END_OF_GRAMMAR'),
:start ::= Value
Value ::= Bool action => doBool
| Number # use auto-action
| String # use auto-action
|| Array
|| Struct
Struct ::= Ident (LCurly) PairList (RCurly) action => doStruct
| (LCurly) PairList (RCurly) action => doStruct1
Array ::= Ident (LCurly) ItemList (RCurly) action => doArray
| (LCurly) ItemList (RCurly) action => doArray1
ItemList::= Value + separator => Comma action => doList
PairList::= Pair + separator => Comma action => doList
Pair ::= Ident (Equal) Value action => doPair
END_OF_GRAMMAR
});
$grammar->precompute;
}
以上是在一个 INIT 块中，因此它将在parse完成之前执行。
现在来我们的行动。每个动作都将使用动作对象作为第一个参数来调用，我们不需要（它有助于更高级的解析技术）。其他参数是匹配的标记/规则的值（不是类型）。大多数这些丢弃或打包参数，或将数据放入稍后定义的对象中。
sub MyActions::first_arg {
say STDERR "rule default action" if DEBUG;
my (undef, $first) = @_;
return $first;
}
sub MyActions::doStruct {
say STDERR "rule Struct" if DEBUG;
my (undef, $ident, $pair_list) = @_;
my %hash;
for (@$pair_list) {
my ($k, $v) = @$_;
$hash{$k} = $v;
}
return MyHash->new($ident, \%hash);
}
sub MyActions::doStruct1 {
say STDERR "rule Struct sans Ident" if DEBUG;
my (undef, $pair_list) = @_;
return MyActions::doStruct(undef, undef, $pair_list);
}
sub MyActions::doArray {
say STDERR "rule Array" if DEBUG;
my (undef, $ident, $items) = @_;
return MyArray->new($ident, $items);
}
sub MyActions::doArray1 {
say STDERR "rule Array sans Ident" if DEBUG;
my (undef, $items) = @_;
MyActions::doArray(undef, undef, $items);
}
sub MyActions::doList {
say STDERR "List" if DEBUG;
my (undef, @list) = @_;
return \@list;
}
sub MyActions::doPair {
say STDERR "Pair" if DEBUG;
my (undef, $key, $value) = @_;
return [$key, $value];
}
sub MyActions::doBool {
say STDERR "Bool" if DEBUG;
my (undef, $bool) = @_;
return MyBool->new($bool);
}
那是相当不起眼的。我们需要这些特殊的对象，因为 (a) 它们稍后会将自己字符串化为正确的形式，以及 (b) 以便我可以关联类型或在花括号之前的任何不完全名称的东西。（而且 (c)，Perl 没有布尔类型，我必须重写它）。
首先是两个助手：$My::Indent设置打印输出将缩进的空格数。My::stringifyHelper只是确保对象被强制转换为它们的字符串表示，并且字符串（不是数字的所有其他内容）都被引号包围。
INIT{ $My::Indent = 4 }
sub My::stringifyHelper {
my (@objects) = @_;
for (@objects) {
if (ref $_) {
$_ = "$_";
} elsif ( not /\A-?\d+(?:\.\d+)?\z/) {
$_ = qq("$_");
}
}
return @objects;
}
这里是MyHash类型。字符串化代码很丑陋，但它似乎可以工作→偶然编程。
{
package MyHash;
sub new {
my ($class, $type, $hashref) = @_;
bless [$type, $hashref] => $class;
}
sub type {
my ($self) = @_;
return $self->[0];
}
sub hash {
my ($self) = @_;
return $self->[1];
}
sub asString {
my ($self) = @_;
my @keys = sort keys %{ $self->hash };
my @vals =
map { s/\n\K/" "x$My::Indent/meg; $_ }
My::stringifyHelper @{ $self->hash }{@keys};
my $string = "";
for my $i (0 .. $#keys) {
$string .= (" "x$My::Indent) . "$keys[$i] = $vals[$i],\n";
}
return +($self->type // "") . "{\n$string}";
}
use overload
'""' => \&asString,
'%{}' => \&hash,
fallback => 1;
}
这实现了MyArray. 字符串化稍微不那么难看，但我将对象表示为哈希。我不够熟练，overload无法确保在访问实际数组时不会递归。
{
package MyArray;
sub new {
my ($class, $type, $aryref) = @_;
bless { type => $type, array => $aryref } => $class;
}
sub type {
my ($self) = @_;
return $self->{type};
}
sub array {
my ($self) = @_;
no overload;
return $self->{array};
}
sub asString {
my ($self) = @_;
my @els = My::stringifyHelper @{$self->array};
my $string = $self->type // "";
if (@els <= 1) {
$string .= "{ @els, }";
} else {
my $els = join '', map "$_,\n", @els;
$els =~ s/^/" "x$My::Indent/meg;
$string .= "{\n$els}";
}
return $string;
}
use overload
'""' => \&asString,
'@{}' => \&array,
fallback => 1;
}
现在小MyBool实现。它甚至应该像布尔值一样工作:)
{
package MyBool;
sub new {
my ($class, $str) = @_;
my $bool;
if ('true' eq lc $str) { $bool = 1 }
elsif ('false' eq lc $str) { $bool = undef }
else { die "Don't know if $str is true or false" }
bless \$bool => $class;
}
use overload
'bool' => sub {
my ($self) = @_;
return $$self;
},
'""' => sub {
my ($self) = @_;
$$self ? 'true' : 'false';
},
fallback => 1;
}
现在我们快完成了。来了main：
sub main {
local $/;
my $data = <DATA>;
my $dsc = parse($data);
say "/:";
say $dsc;
say "/Tools:";
say $dsc->{Tools};
say "/Tools/ShadowDensity/:";
say $dsc->{Tools}{ShadowDensity};
say "/Tools/ShadowDensity/Inputs/:";
say $dsc->{Tools}{ShadowDensity}{Inputs};
return 0;
}
这将加载并解析数据。然后它打印出整个对象，并且只打印出某些部分。到目前为止，这似乎有效。
注意：如果您对作为输入提供的数据运行解析器，它将失败。标记化成功，但您在某处忘记了右括号。修复后，它应该可以工作。
去做：
- 有些部分使用
exit 1应该抛出异常的地方。
- 上述访问有效，但其他路径失败（它们返回 undef）。某处有一个错误，需要修复，但我不知道。
- 更好的错误消息会很棒，调试级别也会更多样化。