ABNF-Grammar
view release on metacpan - search on metacpan
view release on metacpan or search on metacpan
Revision history for Perl extension ABNF::Grammar.
0.08 Sat Jun 16 12:55:35 2013
- removed recursion increment in Honest repetition
- removed debug output
0.07 Sat Jun 16 12:55:35 2013
- better recursion control in Honest generator in case of repetition or choice
0.06 Fri Jun 15 00:00:26 2013
- fixed dependence from Method::Signatures
0.05 Fri Jun 14 23:47:51 2013
- fixed dependence from Method::Signatures
0.04 Fri Jun 14 23:47:51 2013
- added files to MANIFEST
0.03 Fri Jun 14 23:31:51 2013
- minor changes about pod again
- added Regexp::Grammars dependence
0.02 Fri Jun 14 22:14:15 2013
- minor changes about mail and pod
0.01 Tue Jun 4 14:37:35 2013
- original version; created by h2xs 1.23 with options
-b 5.8.8 -XAn ABNF::Grammar
Changes
Makefile.PL
MANIFEST
README
t/ABNF-Grammar.t
t/ABNF-Validator.t
t/ABNF-Generator-Liar.t
t/ABNF-Generator-Honest.t
t/data/test.abnf
lib/ABNF/Grammar.pm
lib/ABNF/Validator.pm
lib/ABNF/Generator.pm
lib/ABNF/Generator/Liar.pm
lib/ABNF/Generator/Honest.pm
META.yml Module YAML meta-data (added by MakeMaker)
META.json Module JSON meta-data (added by MakeMaker)
{
"abstract" : "Validator and generator module for ABNF grammars",
"author" : [
"Arseny Krasikov <nyaapa@cpan.org>"
],
"dynamic_config" : 1,
"generated_by" : "ExtUtils::MakeMaker version 6.66, CPAN::Meta::Converter version 2.112621",
"license" : [
"perl_5"
],
"meta-spec" : {
"url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec",
"version" : "2"
},
"name" : "ABNF-Grammar",
"no_index" : {
"directory" : [
"t",
"inc"
]
},
"prereqs" : {
"build" : {
"requires" : {
"ExtUtils::MakeMaker" : 0
}
},
"configure" : {
"requires" : {
"ExtUtils::MakeMaker" : 0
}
},
"runtime" : {
"requires" : {
"Method::Signatures" : 0,
"Parse::ABNF" : "0.05",
"Readonly" : "1.03",
"Regexp::Grammars" : "1.028",
"Storable" : "2.39",
"perl" : "5.014"
}
}
},
"release_status" : "stable",
"resources" : {
"license" : [
"http://dev.perl.org/licenses/"
]
},
"version" : "0.08"
}
---
abstract: 'Validator and generator module for ABNF grammars'
author:
- 'Arseny Krasikov <nyaapa@cpan.org>'
build_requires:
ExtUtils::MakeMaker: 0
configure_requires:
ExtUtils::MakeMaker: 0
dynamic_config: 1
generated_by: 'ExtUtils::MakeMaker version 6.66, CPAN::Meta::Converter version 2.112621'
license: perl
meta-spec:
url: http://module-build.sourceforge.net/META-spec-v1.4.html
version: 1.4
name: ABNF-Grammar
no_index:
directory:
- t
- inc
requires:
Method::Signatures: 0
Parse::ABNF: 0.05
Readonly: 1.03
Regexp::Grammars: 1.028
Storable: 2.39
perl: 5.014
resources:
license: http://dev.perl.org/licenses/
version: 0.08
Makefile.PL view on Meta::CPAN
use 5.008008;
use strict;
use warnings;
use ExtUtils::MakeMaker;
# See lib/ExtUtils/MakeMaker.pm for details of how to influence
# the contents of the Makefile that is written.
WriteMakefile(
NAME => 'ABNF::Grammar',
DISTNAME => "ABNF-Grammar",
AUTHOR => 'Arseny Krasikov <nyaapa@cpan.org>',
LICENSE => 'perl_5',
VERSION_FROM => 'lib/ABNF/Grammar.pm', # finds $VERSION
ABSTRACT => 'Validator and generator module for ABNF grammars',
PREREQ_PM => {
'Parse::ABNF' => "0.05",
'Storable' => "2.39",
'Method::Signatures' => 0,
'Regexp::Grammars' => "1.028",
'Readonly' => "1.03",
},
META_MERGE => {
requires => { perl => '5.014' },
resources => {
license => 'http://dev.perl.org/licenses/',
},
}
);
ABNF-Grammar version 0.05
=========================
ABNF-Grammar - validator and generator for ABNF grammars.
This module parses IETF ABNF (STD 68, RFC 5234, 4234, 2234) grammars via Parse::ABNF and provides tools to :
* verify validity of string;
* generate valid messages;
* generate invalid messages.
SYNOPSIS
use ABNF::Grammar qw(Grammar);
use ABNF::Generator qw(asStrings);
use ABNF::Generator::Honest qw(Honest);
use ABNF::Generator::Liar qw(Liar);
use ABNF::Validator qw(Validator);
my $grammar = Grammar->new("smtp.bnf", qw(ehlo helo mail rcpt data rset vrfy noop quit data data-terminate));
my $valid = Validator->new($grammar);
my $liar = Liar->new($grammar, $valid);
my $honest = Honest->new($grammar, $valid);
$valid->validate("vrfy", "string");
my @strings = $liar->withoutArguments("vrfy");
my $string = $liar->unExistedCommand("vrfy");
my $string = $liar->endlessCommand("vrfy");
my $string = $liar->generate("helo");
my $string = $honest->generate("helo");
INSTALLATION
To install this module type the following:
perl Makefile.PL
make
make test
make install
DEPENDENCIES
* Parse::ABNF => 0.05;
* Storable => 2.39;
* Method::Signatures => 20130505;
* Readonly => 1.03;
* perl >= 5.014.
BUG REPORTS
Please report bugs in this module via <nyaapa@cpan.org>
AUTHOR / COPYRIGHT / LICENSE
Copyright (c) 2013 Arseny Krasikov <nyaapa@cpan.org>.
This module is licensed under the same terms as Perl itself.
lib/ABNF/Generator.pm view on Meta::CPAN
package ABNF::Generator;
=pod
=head1 NAME
B<ABNF::Generator> - abstract base class for ABNF-based generators
=head1 INHERITANCE
B<ABNF::Generator> is the root of the Honest and Liar generators
=head1 DESCRIPTION
B<ABNF::Generator> is the abstract base class for ABNF-based generators.
Also it provides function B<asStrings> to stringified generated sequences
=head1 METHODS
=cut
use 5.014;
use strict;
use warnings;
no warnings "recursion";
use Carp;
use Readonly;
use Method::Signatures;
use Data::Dumper;
use Parse::ABNF;
use List::Util qw(shuffle);
use ABNF::Grammar qw($BASIC_RULES splitRule);
use ABNF::Validator;
use base qw(Exporter);
our @EXPORT_OK = qw($CONVERTERS $BASIC_RULES $RECURSION_LIMIT);
Readonly our $CHOICE_LIMIT => 128;
Readonly our $CONVERTERS => {
"hex" => sub { hex($_[0]) },
"bin" => sub { oct($_[0]) },
"decimal" => sub { int($_[0]) },
};
=pod
=head1 ABNF::Generator->C<new>($grammar, $validator?)
Creates a new B<ABNF::Generator> object.
$grammar isa B<ABNF::Grammar>.
$validator isa B<ABNF::Validator>.
Children classes can get acces for them by $self->{_grammar} and $self->{_validator}
=cut
method new(ABNF::Grammar $grammar, ABNF::Validator $validator?) {
my $class = ref($self) || $self;
croak "Cant create instance of abstract class" if $class eq 'ABNF::Generator';
$self = {
_cache => {},
_grammar => $grammar,
_validator => $validator || ABNF::Validator->new($grammar)
};
bless($self, $class);
$self->_init();
return $self;
}
method _init() {
$self->{handlers} = {
Range => $self->can("_range"),
String => $self->can("_string"),
Literal => $self->can("_literal"),
Repetition => $self->can("_repetition"),
ProseValue => $self->can("_proseValue"),
Reference => $self->can("_reference"),
Group => $self->can("_group"),
Choice => $self->can("_choice"),
Rule => $self->can("_rule"),
};
}
=pod
=head1 $generator->C<_range>($rule, $recursion)
Generates chain for range element.
Abstract method, most of all children must overload it.
$recursion is a structure to controle recursion depth.
=cut
method _range($rule, $recursion) {
croak "Range handler is undefined yet";
}
=pod
=head1 $generator->C<_string>($rule, $recursion)
Generates chain for string element.
Abstract method, most of all children must overload it
$recursion is a structure to controle recursion depth.
=cut
method _string($rule, $recursion) {
croak "String handler is undefined yet";
}
=pod
=head1 $generator->C<_literal>($rule, $recursion)
Generates chain for literal element.
Abstract method, most of all children must overload it
$recursion is a structure to controle recursion depth.
=cut
method _literal($rule, $recursion) {
croak "Literal handler is undefined yet";
}
=pod
=head1 $generator->C<_repetition>($rule, $recursion)
Generates chain for repetition element.
Abstract method, most of all children must overload it
$recursion is a structure to controle recursion depth.
=cut
method _repetition($rule, $recursion) {
croak "Repetition handler is undefined yet";
}
=pod
=head1 $generator->C<_reference>($rule, $recursion)
Generates chain for reference element.
Abstract method, most of all children must overload it
$recursion is a structure to controle recursion depth.
=cut
method _reference($rule, $recursion) {
croak "Reference handler is undefined yet";
}
=pod
=head1 $generator->C<_group>($rule, $recursion)
Generates chain for group element.
Abstract method, most of all children must overload it
$recursion is a structure to controle recursion depth.
=cut
method _group($rule, $recursion) {
croak "Group handler is undefined yet";
}
=pod
=head1 $generator->C<_choice>($rule, $recursion)
Generates chain for choce element.
Abstract method, most of all children must overload it
$recursion is a structure to controle recursion depth.
=cut
method _choice($rule, $recursion) {
croak "Choice handler is undefined yet";
}
=pod
=head1 $generator->C<_rule>($rule, $recursion)
Generates chain for rule element, usually -- basic element in chain.
Abstract method, most of all children must overload it
$recursion is a structure to controle recursion depth.
=cut
method _rule($rule, $recursion) {
croak "Rule handler is undefined yet";
}
=pod
=head1 $generator->C<_generateChain>($rule, $recursion)
Generates one chain per different rule in $rule.
$rule is structure that Return from B<ABNF::Grammar::rule> and like in B<Parse::ABNF>.
$rule might be a command name.
$recursion is a structure to controle recursion depth.
at init it have only one key -- level == 0.
You can create new object perl call or use one.
See use example in ABNF::Generator::Honest in method _choice
=cut
method _generateChain($rule, $recursion) {
my @result = ();
if ( ref($rule) ) {
croak "Bad rule " . Dumper($rule) unless UNIVERSAL::isa($rule, "HASH");
} elsif ( exists($BASIC_RULES->{$rule}) ) {
$rule = $BASIC_RULES->{$rule};
} else {
$rule = $self->{_grammar}->rule($rule);
}
$self->{handlers}->{ $rule->{class} }
or die "Unknown class " . $rule->{class};
return $self->{handlers}->{ $rule->{class} }->($self, $rule, $recursion);
}
=pod
=head1 $generator->C<generate>($rule, $tail="")
Generates one sequence string for command $rule.
Using cache $self->{_cache}->{$rule} for this rule, that speeds up this call.
$rule is a command name.
$tail is a string added to result if it absent.
dies if there is no command like $rule.
=cut
method generate(Str $rule, Str $tail="") {
croak "Unexisted command" unless $self->{_grammar}->hasCommand($rule);
$self->{_cache}->{$rule} ||= [];
unless ( @{$self->{_cache}->{$rule}} ) {
$self->{_cache}->{$rule} = _asStrings( $self->_generateChain($rule, {level => 0}) );
}
my $result = pop($self->{_cache}->{$rule});
my $rx = eval { qr/$tail$/ };
croak "Bad tail" if $@;
return $result =~ $rx ? $result : $result . $tail;
}
=pod
=head1 $generator->C<withoutArguments>($name, $tail="")
Return an strings starts like command $name and without arguments.
$tail is a string added to a result.
dies if there is no command like $rule.
=cut
method withoutArguments(Str $name, Str $tail="") {
croak "Unexisted command" unless $self->{_grammar}->hasCommand($name);
my ($prefix, $args) = splitRule( $self->{_grammar}->rule($name) );
my $rx = eval { qr/$tail$/ };
croak "Bad tail" if $@;
return $prefix =~ $rx ? $prefix : $prefix . $tail;
}
=pod
=head1 $generator->C<hasCommand>($name)
Return 1 if there is a $name is command, 0 otherwise
=cut
method hasCommand(Str $name) {
$self->{_grammar}->hasCommand($name);
}
=pod
=head1 FUNCTIONS
=head1 C<_asStrings>($generated)
Return stringification of genereted sequences from C<_generateChain>.
Uses in generate call to stringify chains.
=cut
func _asStrings($generated) {
given ( $generated->{class} ) {
when ( "Atom" ) { return [ $generated->{value} ] }
when ( "Sequence" ) {
my $value = $generated->{value};
return [] unless @$value;
my $begin = _asStrings($value->[0]);
for ( my $pos = 1; $pos < @$value; $pos++ ) {
my @new_begin = ();
my $ends = _asStrings($value->[$pos]);
next unless @$ends;
my @ibegin = splice([shuffle(@$begin)], 0, $CHOICE_LIMIT);
my @iends = splice([shuffle(@$ends)], 0, $CHOICE_LIMIT);
foreach my $end ( @iends ) {
foreach my $begin ( @ibegin ) {
push(@new_begin, $begin . $end);
}
}
$begin = \@new_begin;
}
return $begin;
}
when ( "Choice" ) {
return [
map { @{_asStrings($_)} } @{$generated->{value}}
];
}
default { die "Unknown class " . $generated->{class} . Dumper $generated }
}
}
1;
=pod
=head1 AUTHOR / COPYRIGHT / LICENSE
Copyright (c) 2013 Arseny Krasikov <nyaapa@cpan.org>.
This module is licensed under the same terms as Perl itself.
=cut
lib/ABNF/Generator/Honest.pm view on Meta::CPAN
package ABNF::Generator::Honest;
=pod
=head1 NAME
B<ABNF::Generator::Honest> - class to generate valid messages for ABNF-based generators
It have $RECURSION_LIMIT = 16. You can change it to increase lower alarm bound on choices and repetition recursion.
but use it carefully!
=head1 INHERITANCE
B<ABNF::Generator::Honest>
isa B<ABNF::Generator>
=head1 DESCRIPTION
=head1 METHODS
=cut
use 5.014;
use strict;
use warnings;
no warnings "recursion";
use Data::Dumper;
use Readonly;
use List::Util qw(reduce);
use POSIX;
use base qw(ABNF::Generator Exporter);
use Method::Signatures; #some bug in B<Devel::Declare>...
use ABNF::Generator qw($CONVERTERS);
our @EXPORT_OK = qw(Honest);
our $RECURSION_LIMIT = 16;
=pod
=head1 ABNF::Generator::Honest->C<new>($grammar, $validator?)
Creates a new B<ABNF::Generator::Honest> object.
$grammar isa B<ABNF::Grammar>.
$validator isa B<ABNF::Validator>.
=cut
method new(ABNF::Grammar $grammar, ABNF::Validator $validator?) {
$self->SUPER::new($grammar, $validator ? $validator : ());
}
=pod
=head1 $honest->C<generate>($rule, $tail="")
Generates one valid sequence string for command $rule.
Using cache $self->{_cache}->{$rule} for this rule, that speeds up this call.
$rule is a command name.
$tail is a string added to result if it absent.
dies if there is no command like $rule.
=cut
method _range($rule, $recursion) {
my $converter = $CONVERTERS->{$rule->{type}};
my $min = $converter->($rule->{min});
my $max = $converter->($rule->{max});
return {class => "Atom", value => chr($min + int(rand($max - $min + 1)))};
}
method _string($rule, $recursion) {
my $converter = $CONVERTERS->{$rule->{type}};
return {
class => "Atom",
value => join("", map { chr($converter->($_)) } @{$rule->{value}})
};
}
method _literal($rule, $recursion) {
return {class => "Atom", value => $rule->{value}};
}
method _repetition($rule, $recursion) {
my $min = $rule->{min};
my $count = ($rule->{max} || LONG_MAX) - $min;
my @result = ();
push(@result, $self->_generateChain($rule->{value}, $recursion)) while $min--;
if ( $recursion->{level} < $RECURSION_LIMIT ) {
push(@result, $self->_generateChain($rule->{value}, $recursion)) while $count-- && int(rand(2));
}
return {class => "Sequence", value => \@result};
}
method _proseValue($rule, $recursion) {
return $self->_generateChain($rule->{name}, $recursion);
}
method _reference($rule, $recursion) {
return $self->_generateChain($rule->{name}, $recursion);
}
method _group($rule, $recursion) {
my @result = ();
foreach my $elem ( @{$rule->{value}} ) {
push(@result, $self->_generateChain($elem, $recursion));
}
return {class => "Sequence", value => \@result};
}
method _choice($rule, $recursion) {
$recursion->{level}++;
my @result = ();
if ( $recursion->{level} < $RECURSION_LIMIT ) {
foreach my $choice ( @{$rule->{value}} ) {
push(@result, $self->_generateChain($choice, $recursion));
}
} else {
$recursion->{choices} ||= {};
my $candidate = reduce {
if ( not exists($recursion->{choices}->{$a}) ) {
$b
} elsif ( not exists($recursion->{choices}->{$b}) ) {
$a
} else {
$recursion->{choices}->{$a} <=> $recursion->{choices}->{$b}
}
} @{$rule->{value}};
$recursion->{choices}->{$candidate}++;
push(@result, $self->_generateChain( $candidate, $recursion));
$recursion->{choices}->{$candidate}--;
}
$recursion->{level}--;
return {class => "Choice", value => \@result};
}
method _rule($rule, $recursion) {
return $self->_generateChain($rule->{value}, $recursion);
}
=pod
=head1 $honest->C<withoutArguments>($name, $tail="")
Return a string starts like command $name and without arguments if command may have no arguments.
Return an empty string otherwise.
$tail is a string added to result if it absent.
dies if there is no command like $rule.
=cut
method withoutArguments(Str $name, Str $tail="") {
my $result = $self->SUPER::withoutArguments($name, $tail);
return $self->{_validator}->validate($name, $result) ? $result : "";
}
=pod
=head1 FUNCTIONS
=head1 C<Honest>()
Return __PACKAGE__ to reduce class name :3
=cut
func Honest() {
return __PACKAGE__;
}
1;
=pod
=head1 AUTHOR / COPYRIGHT / LICENSE
Copyright (c) 2013 Arseny Krasikov <nyaapa@cpan.org>.
This module is licensed under the same terms as Perl itself.
=cut
lib/ABNF/Generator/Liar.pm view on Meta::CPAN
package ABNF::Generator::Liar;
=pod
=head1 NAME
B<ABNF::Generator::Liar> - class to generate invalid messages for ABNF-based generators
=head1 INHERITANCE
B<ABNF::Generator::Liar>
isa B<BNF::Generator>
=head1 DESCRIPTION
=head1 METHODS
=cut
use 5.014;
use strict;
use warnings;
use Readonly;
use Data::Dumper;
use Carp;
use POSIX;
use base qw(ABNF::Generator Exporter);
use Method::Signatures; #some bug in B<Devel::Declare>...
use ABNF::Grammar qw(splitRule $BASIC_RULES);
Readonly my $STRING_LEN => 20;
Readonly my $CHARS => [map { chr($_) } (0 .. 0x0D - 1), (0x0D + 1 .. 255)];
Readonly my $ACHARS => [('A'..'Z', 'a'..'z')];
Readonly our $ENDLESS => 513 * 1024 / 4; # 513 kB of chars
our @EXPORT_OK = qw(Liar);
=pod
=head1 ABNF::Generator::Liar->C<new>($grammar, $validator?)
Creates a new B<ABNF::Generator::Liar> object.
$grammar isa B<ABNF::Grammar>.
$validator isa B<ABNF::Validator>.
=cut
method new(ABNF::Grammar $grammar, ABNF::Validator $validator?) {
$self->SUPER::new($grammar, $validator ? $validator : ());
}
=pod
=head1 $liar->C<generate>($rule, $tail="")
Generates one invalid sequence string for command $rule.
Using cache $self->{_cache}->{$rule} for this rule, that speeds up this call.
$rule is a command name.
$tail is a string added to result if it absent.
dies if there is no command like $rule.
=cut
method _rule($rule, $recursion) {
my $result = "";
if ( my $prefix = splitRule($rule) ) {
do {
$result = _stringRand($ACHARS);
} while $self->{_validator}->validateArguments($rule->{name}, $result);
$result = $prefix . $result;
} else {
do {
$result = _stringRand($ACHARS);
} while $self->{_validator}->validate($rule->{name}, $result);
}
return {class => "Atom", value => $result};
}
func _stringRand($chars, $len?) {
$len ||= rand($STRING_LEN) + 1;
my @gen = ();
for ( my $i = 0; $i < $len; $i++ ) {
push(@gen, @$chars[rand @$chars]);
}
return join("", @gen);
}
=pod
=head1 $liar->C<withoutArguments>($name, $tail="")
Return a string starts like command $name and without arguments if it possible.
Return an empty string if command may have no arguments.
$tail is a string added to result if it absent.
dies if there is no command like $rule.
=cut
method withoutArguments(Str $name, Str $tail="") {
my $result = $self->SUPER::withoutArguments($name, $tail);
return $self->{_validator}->validate($name, $result) ? "" : $result;
}
=pod
=head1 $liar->C<unExistedCommand>()
Return an string starts with char sequence that doesn't match any command
$tail is a string added to result if it absent.
dies if there is no command like $rule.
=cut
method unExistedCommand(Str $tail="") {
my $result = "";
do {
$result = _stringRand($ACHARS);
} while $self->{_validator}->validateCommand($result);
my $rx = eval { qr/$tail$/ };
croak "Bad tail" if $@;
return $result =~ $rx ? $result : $result . $tail;
}
=pod
=head1 $liar->C<endlessCommand>($name)
Return an string starts like command $name and length more then $ENDLESS = 513 * 1024 / 4
$tail is a string added to result if it absent.
dies if there is no command like $rule.
=cut
method endlessCommand($name, Str $tail="") {
croak "Unexisted commadn $name" unless $self->hasCommand($name);
my $prefix = splitRule($self->{_grammar}->rule($name));
my $result = $prefix . _stringRand($ACHARS, $ENDLESS);
my $rx = eval { qr/$tail$/ };
croak "Bad tail" if $@;
return $result =~ $rx ? $result : $result . $tail;
}
=pod
=head1 FUNCTIONS
=head1 C<Liar>()
Return __PACKAGE__ to reduce class name :3
=cut
func Liar() {
return __PACKAGE__;
}
1;
=pod
=head1 AUTHOR / COPYRIGHT / LICENSE
Copyright (c) 2013 Arseny Krasikov <nyaapa@cpan.org>.
This module is licensed under the same terms as Perl itself.
=cut
lib/ABNF/Grammar.pm view on Meta::CPAN
package ABNF::Grammar;
=pod
=head1 NAME
B<ABNF-Grammar> - validator and generator for ABNF grammars.
B<ABNF::Grammar> - class for inner representation ABNF-grammar.
=head1 VERSION
This document describes B<ABNF::Grammar> version 0.08
=head1 SYNOPSIS
use ABNF::Grammar qw(Grammar);
use ABNF::Generator qw(asStrings);
use ABNF::Generator::Honest qw(Honest);
use ABNF::Generator::Liar qw(Liar);
use ABNF::Validator qw(Validator);
my $grammar = Grammar->new("smtp.bnf", qw(ehlo helo mail rcpt data rset vrfy noop quit data data-terminate));
my $valid = Validator->new($grammar);
my $liar = Liar->new($grammar, $valid);
my $honest = Honest->new($grammar, $valid);
$valid->validate("vrfy", "string");
my @strings = $liar->withoutArguments("vrfy");
my $string = $liar->unExistedCommand("vrfy");
my $string = $liar->endlessCommand("vrfy");
my $string = $liar->generate("helo");
my $string = $honest->generate("helo");
=head1 DESCRIPTION
This module parses IETF ABNF (STD 68, RFC 5234, 4234, 2234) grammars
via B<Parse::ABNF> and provides tools to :
=over 4
=item * verify validity of string
=item * generate valid messages
=item * generate invalid messages
=back
=head1 METHODS
=cut
use 5.014;
use strict;
use warnings;
use Carp;
use Readonly;
use Method::Signatures;
use Data::Dumper;
use Parse::ABNF;
use Storable qw(dclone);
use base "Exporter";
our @EXPORT_OK = qw(splitRule Grammar $BASIC_RULES);
our $VERSION = "0.08";
Readonly our $BASIC_RULES => do {
my $res = {};
foreach my $rule ( @{$Parse::ABNF::CoreRules} ) {
die "Multiple definitions for $rule->{name}" if exists($res->{$rule->{name}});
$res->{$rule->{name}} = $rule;
}
$res;
};
=pod
=head1 ABNF::Grammar->C<new>($fname, @commands)
Creates a new B<ABNF::Grammar> object.
Read ABNF rules from file with $fname.
@commands consists of main command names for generation and validation.
=cut
method new(Str $fname, @commands) {
my $class = ref($self) || $self;
$self = {_commands => { map {$_ => 1} @commands} };
bless($self, $class);
open(my $file, $fname)
or croak "Cant open $fname";
my $content = join("", <$file>) . "\n";
close($file)
or carp "Cant close $fname";
$self->_init($content);
foreach my $command ( @commands ) {
croak "Grammar doesn't have command $command" unless exists($self->{_rules}->{$command});
}
return $self;
}
=pod
=head1 ABNF::Grammar->C<fromString>($content, @commands)
Creates a new B<ABNF::Grammar> object.
Get ABNF rules from string $rule
@commands consists of main command names for generation and validation.
=cut
method fromString(Str $content, @commands) {
my $class = ref($self) || $self;
$self = {_commands => { map {$_ => 1} @commands} };
bless($self, $class);
$self->_init($content . "\n");
foreach my $command ( @commands ) {
croak "Grammar doesn't have command $command" unless exists($self->{_rules}->{$command});
}
return $self;
}
method _init($content) {
my $parser = Parse::ABNF->new();
my $rules = $parser->parse($content)
or croak "Bad rules";
foreach my $rule ( @$rules ) {
croak "Multiple definitions for $rule->{name}" if exists($self->{_rules}->{$rule->{name}});
$self->{_rules}->{$rule->{name}} = $rule;
}
}
=pod
=head1 $grammar->C<rule>($name)
Return rule form $name with name $name.
Result structure is identical to B<Parse::ABNF> structure.
For debug only.
Do not modify result structure.
=cut
method rule(Str $name) {
croak "Unexisted rule $name" unless exists($self->{_rules}->{$name});
$self->{_rules}->{$name};
}
=pod
=head1 $grammar->C<rules>()
Return all rules.
Result structures is identical to B<Parse::ABNF> structure.
For debug only.
Do not modify result structure.
=cut
method rules() {
$self->{_rules};
}
=pod
=head1 $grammar->C<replaceRule>($rule, $value)
Replace $rule with $value.
For debug use only.
dies if there is no rule like $rule.
=cut
method replaceRule(Str $rule, $value) {
croak "Unexisted rule $rule" unless exists($self->{_rules}->{$rule});
croak "new value name must be equal to rule" unless $value->{name} eq $rule;
$self->{_rules}->{$rule} = $value;
}
=pod
=head1 $grammar->C<replaceBasicRule>($rule, $value)
Replace $rule with $value.
For debug use only.
dies if there is no rule like $rule.
=cut
method replaceBasicRule(Str $rule, $value) {
croak "Unexisted rule $rule" unless exists($BASIC_RULES->{$rule});
croak "new value name must be equal to rule" unless $value->{name} eq $rule;
$BASIC_RULES->{$rule} = $value;
}
=pod
=head1 $grammar->C<hasCommand>($name)
Return 1 if $name is command, 0 otherwise.
=cut
method hasCommand(Str $name) {
exists $self->{_commands}->{$name};
}
=pod
=head1 $grammar->C<commands>()
Return all grammar commands as arrayref.
=cut
method commands() {
[ keys $self->{_commands} ]
}
=pod
=head1 FUNCTIONS
=head1 C<splitRule>($rule)
In scalar context return prefix only, in list -- prefix and arguments rules.
$rule is structure that returns from C<rule> and like in B<Parse::ABNF>.
=cut
func splitRule($rule) {
my $value = $rule->{value};
my $prefix = "";
if (
$value->{class} eq 'Group'
&& $value->{value}->[0]->{class} eq 'Literal'
) {
$prefix = $value->{value}->[0]->{value};
$value = dclone($value);
shift($value->{value});
if (
$value->{value}->[0]->{class} eq 'Reference'
&& $value->{value}->[0]->{name} eq 'SP'
) {
$prefix .= "\x20";
shift($value->{value});
}
if (
$value->{value}->[-1]->{class} eq 'Reference'
&& $value->{value}->[-1]->{name} eq 'CRLF'
) {
pop($value->{value});
}
}
return wantarray ? ($prefix, $value) : $prefix;
}
=pod
=head1 C<Grammar>()
Return __PACKAGE__ to reduce class name :3
=cut
func Grammar() {
return __PACKAGE__;
}
1;
__END__
=pod
=head1 DEPENDENCIES
=over 4
=item B<Parse::ABNF>
=item B<Regexp::Grammars>
=item B<Storable>
=item B<Method::Signatures>
=item B<Readonly>
=item B<perl 5.014>
=back
=head1 BUG REPORTS
Please report bugs in this module via <nyaapa@cpan.org>
=head1 SEE ALSO
=over 4
=item * ABNF RFC
L<http://www.ietf.org/rfc/rfc5234.txt>
=item * Abnf parser
L<Parse::ABNF>
=item * Validator base
L<Regexp::Grammars>
=item * Cool guy from monks with idea how to validate
L<http://www.perlmonks.org/?node_id=957506>
=back
=head1 AUTHOR / COPYRIGHT / LICENSE
Copyright (c) 2013 Arseny Krasikov <nyaapa@cpan.org>.
This module is licensed under the same terms as Perl itself.
=cut
lib/ABNF/Validator.pm view on Meta::CPAN
package ABNF::Validator;
=pod
=head1 NAME
ABNF::Validator - class to verify strings based on ABNF-grammars
=head1 DESCRIPTION
=head1 METHODS
=cut
use 5.014;
use strict;
use warnings;
use re 'eval';
use Carp;
use Readonly;
use Method::Signatures;
use Data::Dumper;
use Parse::ABNF;
use ABNF::Grammar qw(splitRule $BASIC_RULES);
use base qw(Exporter);
our @EXPORT_OK = qw(Validator);
Readonly my $ARGUMENTS_RULES => "generic_arguments_rule_for_";
Readonly my $CLASS_MAP => {
Choice => \&_choice,
Group => \&_group,
Range => \&_range,
Reference => \&_reference,
Repetition => \&_repetition,
Rule => \&_rule,
String => \&_string,
Literal => \&_literal,
ProseValue => \&_proseValue
};
=pod
=head1 ABNF::Validator->C<new>($grammar)
Creates a new B<ABNF::Validator> object.
$grammar isa B<ABNF::Grammar>.
=cut
method new(ABNF::Grammar $grammar) {
my $class = ref($self) || $self;
$self = { _grammar => $grammar };
bless($self, $class);
$self->_init();
return $self;
}
method _init() {
my $commands = $self->{_grammar}->commands();
$self->{_commandsPattern} = do {
my $pattern = join(" | ", @$commands);
qr/\A (?: $pattern ) \Z/ix;
};
$self->{_rules} = _value([
values($self->{_grammar}->rules()),
values($BASIC_RULES)
]);
$self->{_regexps} = do {
use Regexp::Grammars;
my %res = ();
foreach my $token ( @$commands ) {
# command
my $str = "
#<logfile: /dev/null>
^ <" . _fixRulename($token) . "> \$
$self->{_rules}
";
$res{$token} = qr{$str }ixs;
# arguments
my $value = $self->{_grammar}->rule($token);
my $name = _fixRulename($ARGUMENTS_RULES . $token);
my $rule = {class => "Rule", name => $name};
my $val = (splitRule($value))[-1];
if ( $value->{value} != $val ) {
$rule->{value} = $val;
my $converted = _value($rule);
$res{$name} = qr{
^ <$name> $
$converted
$self->{_rules}
}xis;
}
}
\%res;
};
}
func _value($val, $dent = 0) {
if ( UNIVERSAL::isa($val, 'ARRAY') ) {
return join('', map { _value($_ , $dent) } @$val);
} elsif ( UNIVERSAL::isa($val, 'HASH') && exists($CLASS_MAP->{ $val->{class} }) ) {
return $CLASS_MAP->{ $val->{class} }->($val, $dent);
} else {
croak "Unknown substance " . Dumper($val);
}
}
func _choice($val, $dent) {
return "(?: " . join(' | ', map { _value($_ , $dent + 1) } @{$val->{value}}) . ")";
}
func _group($val, $dent) {
return '(?: ' . _value($val->{value}, $dent + 1) . ' )';
}
func _reference($val, $dent) {
return "<" . _fixRulename($val->{name}) . ">";
}
func _repetition($val, $dent) {
no warnings 'uninitialized';
my %maxMin = (
# max min
"1 0" => '?',
" 0" => '*',
" 1" => '+',
);
if ( my $mm = $maxMin{"$val->{max} $val->{min}"} ) {
return " (?: " . _value($val->{value}, $dent + 1) . " )$mm ";
} elsif( $val->{min} == $val->{max} ){
return " (?: ". _value($val->{value}, $dent + 1) . " ){$val->{max}} ";
} else {
return " (?: " . _value($val->{value}, $dent+1) . " ){$val->{min}, $val->{max}} ";
}
}
func _rule($val, $dent) {
my $ret = "";
my $name = $val->{name};
if ( 'ws' eq lc($name) ) {
warn "Changing rule ws to token to avoid 'infinitely recursive unpleasantness.'\n";
$ret .= "<rule: ws>\n "; # may be token
} else {
$ret .= "<token: " . _fixRulename($val->{name}) . ">\n ";
}
$ret .= _value($val->{value}, $dent + 1);
$ret . "\n\n";
}
#~ @{[_fixRulename($$v{name})]}
func _fixRulename($name) {
$name =~ s/[-\W]/_/g;
$name;
}
func _range($val, $dent) {
my $ret = "";
$ret .= '[';
given ( $val->{type} ) {
when ( 'hex' ) {
$ret .= join('-', map { '\x{' . $_ . '}' } $val->{min}, $val->{max});
}
when ( 'binary' ) {
$ret .= join('-', map { sprintf('\\%o', oct("0b$_")) } $val->{min}, $val->{max});
}
when ( 'decimal' ) {
$ret .= join('-', map { sprintf('\\%o', $_) } $val->{min}, $val->{max});
}
default {
croak "## Range type $val->{type} $val->{value} \n";
}
}
$ret .= "]";
$ret;
}
func _string($val, $dent) {
my $ret = "";
given ( $val->{type} ) {
when ( 'hex' ) {
$ret = join('', map { '\x' . $_ } @{$val->{value}});
}
when ( 'binary' ) {
$ret .= join('', map { sprintf('\\%o', oct("0b$_")) } @{$val->{value}});
}
when ( 'decimal' ) {
$ret .= join('', map { sprintf('\\%o', $_) } @{$val->{value}});
}
default {
die "## String type $val->{type} $val->{value} \n";
}
#~ warn "##", map({ "$_ ( $val->{$_} ) " } sort keys %$val ), "\n";
}
#~ " $ret ";
$ret;
}
func _literal($val, $dent) {
return quotemeta($val->{value});
}
func _proseValue($val, $dent) {
return "<" . _fixRulename($val->{value}) . ">";
}
=pod
=head1 $validator->C<validate>($rule, $string)
Return 1 if $string matches $rule and 0 otherwise.
$rule is rulename.
$string is arguments string.
dies if there is no command like $rule.
=cut
method validate(Str $rule, Str $string) {
croak "Unexisted command $rule" unless exists($self->{_regexps}->{$rule});
scalar($string =~ $self->{_regexps}->{$rule});
}
=pod
=head1 $validator->C<validateArguments>($rule, $string)
Return 1 if $string matches arguments rules form $rule and 0 otherwise.
$rule is rulename.
$string is arguments string.
dies if there is no command like $rule.
=cut
method validateArguments($rule, $string) {
croak "Unexisted command $rule" unless exists($self->{_regexps}->{$rule});
my $args = _fixRulename($ARGUMENTS_RULES . $rule);
scalar(exists($self->{_regexps}->{$args}) && ($string =~ $self->{_regexps}->{$args}));
}
=pod
=head1 $validator->C<validateCommand>($command)
Return 1 if there exists command like $command and 0 otherwise
=cut
method validateCommand($command) {
return $command =~ $self->{_commandsPattern};
}
=pod
=head1 $validator->C<hasCommand>($command)
Return 1 if there exists command like $command and 0 otherwise
=cut
method hasCommand($command) {
return exists($self->{_regexps}->{$command});
}
=pod
=head1 FUNCTIONS
=head1 C<Validator>()
Return __PACKAGE__ to reduce class name :3
=cut
func Validator() {
return __PACKAGE__;
}
1;
=pod
=head1 AUTHOR / COPYRIGHT / LICENSE
Copyright (c) 2013 Arseny Krasikov <nyaapa@cpan.org>.
This module is licensed under the same terms as Perl itself.
=cut
t/ABNF-Generator-Honest.t view on Meta::CPAN
use strict;
use warnings;
use Data::Dumper;
use Test::More tests => 26;
use ABNF::Grammar qw(Grammar);
use ABNF::Validator qw(Validator);
BEGIN {
use_ok('ABNF::Generator::Honest', qw(Honest));
};
my $grammar = Grammar->new("t/data/test.abnf", qw(token pair expr noop minus));
$grammar->replaceBasicRule("CRLF", {
class => "Rule",
name => "CRLF",
value => {
class => "Literal",
value => "\n"
}
});
my $valid = Validator->new($grammar);
my $honest = eval { Honest->new($grammar, $valid) };
ok($honest, "Create Honest validator");
eval { $honest->generate("lol") };
ok($@, "Ok no rule");
for ( 1 .. 20 ) {
my $str = $honest->generate("expr");
1 while $str =~ s@[\+\-\*\/]\s\d+\s\d+@0@g;
like($str, qr/^\d+$/, "Generated str is ok");
}
is($honest->withoutArguments("noop", "\n"), "noop\n", "Without arguments for noop");
is($honest->withoutArguments("minus", "\n"), "", "Without arguments for minus");
eval { $honest->withoutArguments("lol") };
ok($@, "Ok no rule");
t/ABNF-Generator-Liar.t view on Meta::CPAN
use strict;
use warnings;
use Test::More tests => 29;
use ABNF::Grammar qw(Grammar);
use ABNF::Validator qw(Validator);
BEGIN {
use_ok('ABNF::Generator::Liar', qw(Liar))
};
my $grammar = eval { Grammar->new("t/data/test.abnf", qw(token pair expr minus noop)) };
$grammar->replaceBasicRule("CRLF", {
class => "Rule",
name => "CRLF",
value => {
class => "Literal",
value => "\n"
}
});
my $valid = Validator->new($grammar);
my $liar = Liar->new($grammar, $valid);
ok($liar, "Create Liar validator");
eval { $liar->generate("lol") };
ok($@, "Ok no rule");
for ( 1 .. 20 ) {
my $str = $liar->generate("minus");
1 while $str =~ s@[\+\-\*\/]\s\d+\s\d+@0@g;
unlike($str, qr/^\d+$/, "Generated str isn't ok");
}
is($liar->withoutArguments("noop", "\n"), "", "Without arguments for noop");
like($liar->withoutArguments("minus", "\n"), qr/^-\s*\n$/, "Without arguments for minus");
eval { $liar->withoutArguments("lol") };
ok($@, "Ok no rule");
ok(!$liar->hasCommand($liar->unExistedCommand()), "Ok unexisted command");
ok(length($liar->endlessCommand("minus", "\n")) > 1024, "Ok long rule");
eval { $liar->endlessCommand("noopasa", "\n") };
ok($@, "Ok no rule");
t/ABNF-Grammar.t view on Meta::CPAN
use strict;
use warnings;
use Test::More tests => 14;
BEGIN { use_ok('ABNF::Grammar', qw(Grammar)) };
my $grammar = eval { Grammar->new("t/data/test.abnf", qw(token pair expr)) };
isa_ok(
$grammar,
"ABNF::Grammar",
"Create test grammar"
);
ok(
!eval {
Grammar->new("t/data/test.abnf", qw(token pair expr lol))
},
"Cant create with unexisted command"
);
my $token = eval { $grammar->rule("expr") };
ok(
$token,
"Get token rule"
);
ok(
!eval {
eval { $grammar->rule("DIGIT") }
},
"Cant get unexisted rule"
);
ok(
$grammar->rules(),
"Get all rules"
);
ok(
$grammar->hasCommand("expr"),
"Is command on command good"
);
ok(
!$grammar->hasCommand("lol"),
"Is command on non-command bad"
);
eval{
$grammar->replaceBasicRule("CRLF", {
class => "Rule",
name => "CRLF",
value => {
class => "Literal",
value => "\n"
}
})
};
ok(!$@, "Ok replace");
eval{
$grammar->replaceBasicRule("CRLF", {
class => "Rule",
name => "CRLFAA",
value => {
class => "Literal",
value => "\n"
}
})
};
ok($@, "Cant replace with name != rule");
eval{
$grammar->replaceBasicRule("CRLFAA", {
class => "Rule",
name => "CRLFAA",
value => {
class => "Literal",
value => "\n"
}
})
};
ok($@, "Cant replace unexisted rule");
eval{
$grammar->replaceRule("noop", {
class => "Rule",
name => "noop",
value => {
class => "Literal",
value => "\n"
}
})
};
ok(!$@, "Ok replace");
eval{
$grammar->replaceRule("noop", {
class => "Rule",
name => "noopaa",
value => {
class => "Literal",
value => "\n"
}
})
};
ok($@, "Cant replace with name != rule");
eval{
$grammar->replaceRule("noopaa", {
class => "Rule",
name => "noopaa",
value => {
class => "Literal",
value => "\n"
}
})
};
ok($@, "Cant replace unexisted rule");
t/ABNF-Validator.t view on Meta::CPAN
use strict;
use warnings;
use Data::Dumper;
use Test::More tests => 11;
use ABNF::Grammar qw(Grammar);
BEGIN {
use_ok('ABNF::Validator', qw(Validator));
};
my $grammar = Grammar->new("t/data/test.abnf", qw(token pair expr minus noop));
$grammar->replaceBasicRule("CRLF", {
class => "Rule",
name => "CRLF",
value => {
class => "Literal",
value => "\n"
}
});
my $valid = eval { Validator->new($grammar) };
ok($valid, "Create new object on ABNF::Grammar");
ok($valid->validate("noop", "noop\n"), "Ok noop");
ok($valid->validate("expr", "- 1 5"), "Ok valid");
ok(!$valid->validate("expr", "1 + 5"), "Ok invalid");
eval { $valid->validate("lol", "1 + 5") };
ok($@, "Ok no rule");
ok($valid->validateArguments("minus", "1 5"), "Ok valid arguments");
ok(!$valid->validateArguments("minus", "1 + 5"), "Ok invalid arguments");
eval { $valid->validateArguments("lol", "1 + 5") };
ok($@, "Ok no rule");
ok($valid->validateCommand("expr"), "Ok command");
ok(!$valid->validateCommand("lol"), "Ok not a command");
t/data/test.abnf view on Meta::CPAN
expr = token
token = ((("+" / "*" / "/") SP pair / minus) / number)
minus = "-" SP pair
pair = token SP token
number = 1*DIGIT
noop = "noop" CRLF
view release on metacpan - search on metacpan
( run in 0.844 second using v1.00-cache-2.02-grep-82fe00e-cpan-1925d2aa809 )