————————————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.03
=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;
our
@EXPORT_OK
=
qw(splitRule Grammar $BASIC_RULES)
;
our
$VERSION
= 0.03;
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
=item * Abnf parser
L<Parse::ABNF>
=item * Validator base
L<Regexp::Grammars>
=item * Cool guy from monks with idea how to validate
=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