lib/Params/Validate/Strict/BNF.pm

        start → end → jump
        

    1: package Params::Validate::Strict::BNF;
    2: 
    3: use strict;
    4: use warnings;
    5: use Carp qw(croak);
    6: use Exporter qw(import);
    7: use Params::Validate::Strict qw(validate_strict);
    8: 
    9: our $VERSION = '0.41';
   10: our @EXPORT_OK = qw(bnf_to_matcher);
   11: 
   12: my %_cache;
   13: 
   14: =head1 NAME
   15: 
   16: Params::Validate::Strict::BNF - compile a BNF grammar to a string matcher
   17: 
   18: =head1 SYNOPSIS
   19: 
   20:   use Params::Validate::Strict::BNF qw(bnf_to_matcher);
   21: 
   22:   my $matcher = bnf_to_matcher([
   23:       '<greeting> ::= "hello" | "hi"',
   24:   ]);
   25:   $matcher->('hello');  # 1
   26:   $matcher->('bye');    # 0
   27: 
   28: =head1 DESCRIPTION
   29: 
   30: Converts an arrayref of BNF grammar lines into a closure that tests whether
   31: a string is a member of the language defined by that grammar.
   32: 
   33: Used internally by L<Params::Validate::Strict> when a schema rule includes a
   34: C<bnf> key.  Results are cached by grammar content, so repeated calls with
   35: the same grammar pay no compilation cost after the first call.
   36: 
   37: =head1 GRAMMAR FORMAT
   38: 
   39: Each element of the arrayref is either a rule definition or a continuation line.
   40: 
   41: =head2 Rule definition
   42: 
   43:   '<rule-name> ::= <alternatives>'
   44: 
   45: The left-hand side is a non-terminal name enclosed in angle brackets.
   46: The right-hand side is one or more alternatives separated by C<|>.
   47: 
   48: =head2 Continuation lines
   49: 
   50: A line that contains no C<::=> is appended (with a space) to the preceding
   51: rule's right-hand side.  This lets long rules span multiple array elements:
   52: 
   53:   '<telephone-number> ::= <country-code-opt> <area-code> <separator-opt>',
   54:   '<central-office-code> <separator-opt> <station-code>',
   55: 
   56: =head2 Terminals
   57: 
   58: Literal text is enclosed in double quotes.  An empty terminal C<""> matches
   59: the empty string (makes a production optional):
   60: 
   61:   '<sep> ::= "" | "-" | " "'
   62: 
   63: Backslash escapes inside terminals (e.g. C<"\"">) are passed through to the
   64: compiled regex via C<quotemeta>, so no special treatment is needed for regex
   65: metacharacters.
   66: 
   67: =head2 Non-terminals
   68: 
   69: References to other rules are enclosed in angle brackets: C<< <rule-name> >>.
   70: Recursive rules are not supported and will raise an exception.
   71: 
   72: =head2 Start rule
   73: 
   74: The first rule defined in the grammar is the start rule.  A value must match
   75: the language generated by that rule (anchored C<^...$>) to be accepted.
   76: 
   77: =head1 FUNCTIONS
   78: 
   79: =head2 bnf_to_matcher( \@grammar_lines )
   80: 
   81: =head3 Purpose
   82: 
   83: Compiles a BNF grammar into a reusable string-membership predicate.
   84: Parses the grammar lines into production rules, builds a compiled regular
   85: expression, and returns a closure that tests whether a given string belongs
   86: to the language.  Results are cached by grammar content so repeated calls with
   87: identical grammar lines pay the compilation cost only once.
   88: 
   89: =head3 Arguments
   90: 
   91: =head4 grammar_lines (required)
   92: 
   93: An arrayref of one or more BNF grammar lines.  Each line is either a rule
   94: definition (C<< '<name> ::= <rhs>' >>) or a continuation line (no C<::=>,
   95: appended to the preceding rule with a space).  Terminals are double-quoted;
   96: non-terminals use angle brackets; alternatives are separated by C<|>.
   97: 
   98: =head3 Returns
   99: 
  100: A code reference C<sub ($str) -> 0|1> that returns C<1> if C<$str> is defined
  101: and matches the start rule, C<0> otherwise (including when C<$str> is undef).
  102: 
  103: =head3 Side Effects
  104: 
  105: The compiled matcher is stored in a module-level cache keyed by grammar
  106: content and is never freed.  Grammars are expected to be defined once at
  107: program start-up and reused across many calls.
  108: 
  109: =head3 Usage Example
  110: 
  111:   use Params::Validate::Strict::BNF qw(bnf_to_matcher);
  112: 
  113:   my $is_colour = bnf_to_matcher([
  114:       '<colour> ::= "red" | "green" | "blue"',
  115:   ]);
  116: 
  117:   $is_colour->('red');    # 1
  118:   $is_colour->('purple'); # 0
  119:   $is_colour->(undef);    # 0
  120: 
  121: =head3 API SPECIFICATION
  122: 
  123: =head4 Input
  124: 
  125:   grammar_lines => {
  126:       type => 'arrayref',
  127:       min  => 1,
  128:   }
  129: 
  130: =head4 Output
  131: 
  132:   { type => 'coderef' }
  133: 
  134: The returned coderef has the signature C<sub ($str) -> 0|1>.
  135: 
  136: =head3 FORMAL SPECIFICATION
  137: 
  138:   bnf_to_matcher : seq STRING -> (STRING U {undef}) -> B
  139: 
  140:   Let G = <N, T, P, S> be the grammar derived from grammar_lines, where
  141:     N  -- set of non-terminals (angle-bracket names)
  142:     T  -- set of terminals  (double-quoted literals)
  143:     P  -- set of productions in N x (N U T)*
  144:     S  -- start symbol (first defined non-terminal)
  145: 
  146:   L(G) = { w in T* | S =>* w }      (language generated by G)
  147: 
  148:   bnf_to_matcher(lines) =def= lambda s.
  149:       if s is undef then 0
  150:       else if s in L(G) then 1
  151:       else 0
  152: 
  153:   Pre-conditions:
  154:     lines /= empty
  155:     for all n in N referenced in P: n is defined in P  (no dangling non-terminals)
  156:     no cycle in the non-terminal reference graph         (no left recursion / loops)
  157: 
  158:   Post-conditions:
  159:     result is a coderef
  160:     for all s: result(s) = 1  iff  s in L(G)
  161:     result(undef) = 0
  162: 
  163: Raises an exception if:
  164: 
  165: =over 4
  166: 
  167: =item * the argument is not an arrayref
  168: 
  169: =item * the grammar contains no rule definitions
  170: 
  171: =item * a non-terminal reference is not defined elsewhere in the grammar
  172: 
  173: =item * a recursive rule is detected
  174: 
  175: =back
  176: 
  177: =cut
  178: 
  179: sub bnf_to_matcher {
●180 → 203 → 213  180: 	my ($grammar_lines) = @_;
  181: 
  182: 	validate_strict({
  183: 		input  => { grammar_lines => $grammar_lines },
  184: 		schema => {
  185: 			grammar_lines => {
  186: 				type => 'arrayref',
  187: 				min  => 1,
  188: 			},
  189: 		},
  190: 	});
  191: 
  192: 	my $cache_key = join("\0", @$grammar_lines);
  193: 	return $_cache{$cache_key} if exists $_cache{$cache_key};
  Mutants (Total: 2, Killed: 2, Survived: 0)
  194: 
  195: 	my (%rules, @rule_order);
  196: 	my ($current_rule, $current_rhs);
  197: 
  198: 	my $flush = sub {
  199: 		return unless defined $current_rule;
  200: 		$rules{$current_rule} = _parse_rhs($current_rhs);
  201: 	};
  202: 
  203: 	for my $line (@$grammar_lines) {
  204: 		if($line =~ /^\s*(<[^>]+>)\s*::=\s*(.*)$/) {
  Mutants (Total: 1, Killed: 1, Survived: 0)
  205: 			$flush->();
  206: 			$current_rule = $1;
  207: 			push @rule_order, $current_rule unless exists $rules{$current_rule};
  208: 			$current_rhs = $2;
  209: 		} elsif(defined $current_rule && $line =~ /\S/) {
  210: 			$current_rhs .= " $line";
  211: 		}
  212: 	}
  213: 	$flush->();
  214: 
  215: 	croak 'bnf_to_matcher: no rules found in grammar' unless @rule_order;
  216: 
  217: 	my $start    = $rule_order[0];
  218: 	my $regex_str = _rule_to_regex($start, \%rules, {});
  219: 	my $re        = qr/^(?:$regex_str)$/s;
  220: 
  221: 	my $matcher = sub { defined($_[0]) && $_[0] =~ $re ? 1 : 0 };
  222: 	$_cache{$cache_key} = $matcher;
  223: 	return $matcher;
  Mutants (Total: 2, Killed: 2, Survived: 0)
  224: }
  225: 
  226: sub _parse_rhs {
●227 → 230 → 242  227: 	my $rhs = $_[0];
  228: 	my @alternatives;
  229: 
  230: 	for my $alt (split /\s*\|\s*/, $rhs) {
  231: 		my @tokens;
  232: 		while($alt =~ /("(?:[^"\\]|\\.)*"|<[^>]+>)/g) {
  233: 			my $tok = $1;
  234: 			if($tok =~ /^"(.*)"$/s) {
  Mutants (Total: 1, Killed: 1, Survived: 0)
  235: 				push @tokens, { type => 'terminal', value => $1 };
  236: 			} else {
  237: 				push @tokens, { type => 'nonterminal', name => $tok };
  238: 			}
  239: 		}
  240: 		push @alternatives, \@tokens;
  241: 	}
  242: 	return \@alternatives;
  Mutants (Total: 2, Killed: 2, Survived: 0)
  243: }
  244: 
  245: sub _rule_to_regex {
●246 → 255 → 267  246: 	my ($rule_name, $rules, $seen) = @_;
  247: 	croak "bnf_to_matcher: undefined rule '$rule_name' referenced in grammar"
  248: 		unless exists $rules->{$rule_name};
  249: 	croak "bnf_to_matcher: recursive rule '$rule_name' is not supported"
  250: 		if $seen->{$rule_name};
  251: 
  252: 	local $seen->{$rule_name} = 1;
  253: 
  254: 	my @alt_regexes;
  255: 	for my $alt (@{ $rules->{$rule_name} }) {
  256: 		my $alt_re = '';
  257: 		for my $tok (@$alt) {
  258: 			if($tok->{type} eq 'terminal') {
  Mutants (Total: 1, Killed: 1, Survived: 0)
  259: 				$alt_re .= quotemeta($tok->{value});
  260: 			} else {
  261: 				$alt_re .= _rule_to_regex($tok->{name}, $rules, $seen);
  262: 			}
  263: 		}
  264: 		push @alt_regexes, $alt_re;
  265: 	}
  266: 
  267: 	return @alt_regexes == 1
  Mutants (Total: 3, Killed: 3, Survived: 0)
  268: 		? $alt_regexes[0]
  269: 		: '(?:' . join('|', @alt_regexes) . ')';
  270: }
  271: 
  272: 1;
  273: 
  274: __END__
  275: 
  276: =head1 SEE ALSO
  277: 
  278: L<Params::Validate::Strict>
  279: 
  280: =head1 AUTHOR
  281: 
  282: Nigel Horne E<lt>njh@nigelhorne.comE<gt>
  283: 
  284: =head1 LICENSE
  285: 
  286: Copyright 2026 Nigel Horne.
  287: 
  288: This program is released under the following licence: GPL2.
  289: If you use it,
  290: please let me know.
  291: 
  292: =cut