ABNF-Grammar

 view release on metacpan or  search on metacpan

lib/ABNF/Generator.pm  view on Meta::CPAN

}

=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

lib/ABNF/Generator.pm  view on Meta::CPAN

	$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

lib/ABNF/Generator/Honest.pm  view on Meta::CPAN

=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)))};
}

lib/ABNF/Generator/Honest.pm  view on Meta::CPAN

}

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

lib/ABNF/Generator/Liar.pm  view on Meta::CPAN

=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);

lib/ABNF/Generator/Liar.pm  view on Meta::CPAN

	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

lib/ABNF/Grammar.pm  view on Meta::CPAN

	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";

lib/ABNF/Grammar.pm  view on Meta::CPAN

	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.

lib/ABNF/Validator.pm  view on Meta::CPAN

	$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

lib/ABNF/Validator.pm  view on Meta::CPAN

=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

t/ABNF-Generator-Liar.t  view on Meta::CPAN

	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

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 {

t/ABNF-Grammar.t  view on Meta::CPAN

	"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"
		}

t/ABNF-Validator.t  view on Meta::CPAN

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");