Это решение использует 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-->.
$match, если подобное закрытие. Он перебирает все доступные токены и возвращает соответствующий токен или ложное значение в случае сбоя. Он использует m/\G.../gc регулярных выражений. Они похожи на s/^...//, но не уничтожают строку. Утверждения \G будут соответствовать pos($string). Опция /c гарантирует, что сбой не изменит pos.
Токен строки сопоставляется вручную. Возможно, вы захотите обработать побеги. Я добавил поддержку нескольких популярных escape-последовательности (\\, \", \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;
}
Теперь уточняем грамматику. Марпу можно обрабатывать с помощью нотации, подобной БНФ, которую я использую здесь. Это в основном синтаксический сахар над методами более низкого уровня. Я могу указать действия (о которых напишу позже) и принять решение не захватывать токены, помещая их в круглые скобки. На данном этапе я могу работать только с типами токенов, а не со значением токенов. После того, как я укажу грамматику, я должен скомпилировать ее с помощью $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);
}
Это было довольно не зрелищно. Нам нужны эти специальные объекты, потому что (а) они позже преобразуются в правильную форму и (б) так что я могу ассоциировать типы или что-то еще, что это не-совсем-название перед завитушками. (И (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). Где-то есть ошибка, которую нужно исправить, но я понятия не имею.
- Было бы здорово улучшить сообщения об ошибках и увеличить разнообразие уровней отладки.
person
amon
schedule
18.02.2013
Alpha=только в том случае, если он появляется вCompostion/Tools/ShadowDensity/Inputs. - person Jokester schedule 18.02.2013s/(\s+StyledText = Input \{ Value = ")[^"]+/$1$your_new_value/`, в противном случае вы должны найти модуль для его разбора или написать свой собственный. - person ArtM schedule 18.02.2013