#!perl -w
use strict;
use warnings;
use Parse::ABNF;
use XML::Writer;
use Data::Dumper;
our $NS = 'http://example.org/grammar';
my %hash = (
Rule => sub {
my ($w, $n) = @_;
my @combine = ($n->{combine} and $n->{combine} eq 'choice') ?
(combine => 'choice') : ();
$w->startTag([$NS, 'define'], name => $n->{name}, @combine);
Conv($w, $n->{value});
$w->endTag([$NS, 'define']);
},
Choice => sub {
my ($w, $n) = @_;
$w->startTag([$NS, 'choice']);
Conv($w, $n->{value});
$w->endTag([$NS, 'choice']);
},
Group => sub {
my ($w, $n) = @_;
$w->startTag([$NS, 'group']);
Conv($w, $n->{value});
$w->endTag([$NS, 'group']);
},
Reference => sub {
my ($w, $n) = @_;
$w->startTag([$NS, 'ref'], name => $n->{name});
$w->endTag([$NS, 'ref']);
},
ProseValue => sub {
my ($w, $n) = @_;
$w->startTag([$NS, 'ref'], name => $n->{value});
$w->endTag([$NS, 'ref']);
warn "Warning: Turning prose value <$n->{value}> into <ref/> pattern\n";
},
Literal => sub {
my ($w, $n) = @_;
$w->startTag([$NS, 'value'], type => 'ascii-insensitive-string');
$w->characters($n->{value});
$w->endTag([$NS, 'value']);
},
Repetition => sub {
my ($w, $n) = @_;
$w->startTag([$NS, 'repetition'], min => $n->{min}, max =>
defined $n->{max} ? $n->{max} : 'unbounded');
Conv($w, $n->{value});
$w->endTag([$NS, 'repetition']);
},
String => sub {
my ($w, $n) = @_;
my @value = $n->{type} eq 'hex' ? map hex, @{$n->{value}} :
@{$n->{value}};
$w->startTag([$NS, 'group']);
foreach my $val (@value) {
$w->startTag([$NS, 'data'], type => 'class');
$w->startTag([$NS, 'param'], name => 'range');
$w->characters(sprintf qq(#%04X-#%04X), $val, $val);
$w->endTag([$NS, 'param']);
$w->endTag([$NS, 'data']);
}
$w->endTag([$NS, 'group']);
},
Range => sub {
my ($w, $n) = @_;
my ($min, $max) = $n->{type} eq 'hex'
? (map hex, ($n->{min}, $n->{max}))
: ($n->{min}, $n->{max});
$w->startTag([$NS, 'data'], type => 'class');
$w->startTag([$NS, 'param'], name => 'range');
$w->characters(sprintf qq(#%04X-#%04X), $min, $max);
$w->endTag([$NS, 'param']);
$w->endTag([$NS, 'data']);
},
);
sub Conv {
my ($w, $n) = @_;
return $hash{$n->{class}}->($w, $n) if ref $n ne 'ARRAY';
return map $hash{$_->{class}}->($w, $_), @$n;
}
printf STDERR "Reading ABNF grammar from STDIN\n";
my $text = join '', <>;
# remove some offending leading white space
$text =~ s/^\s+(?=[\w-]+\s*=)//mg;
my $rules = Parse::ABNF->new->parse($text, 0);
die unless $rules;
my $w = XML::Writer->new(NAMESPACES => 1);
$w->addPrefix($NS);
$w->startTag([$NS, 'grammar']);
Conv($w, $rules);
$w->endTag([$NS, 'grammar']);