File Coverage

blib/lib/Regexp/Parsertron.pm

Criterion	Covered	Total	%
statement	213	243	87.6
branch	74	102	72.5
condition	7	12	58.3
subroutine	27	33	81.8
pod	11	13	84.6
total	332	403	82.3

package Regexp::Parsertron;

use strict;
use warnings;
#use warnings qw(FATAL utf8); # Fatalize encoding glitches.

use Data::Section::Simple 'get_data_section';

use Marpa::R2;

use Moo;

use Scalar::Does '-constants'; # For does().

use Tree;

use Try::Tiny;

use Types::Standard qw/Any Int Str/;

has bnf =>
(
	default  => sub{return ''},
	is       => 'rw',
	isa      => Any,
	required => 0,
);

has current_node =>
(
	default  => sub{return ''},
	is       => 'rw',
	isa      => Any,
	required => 0,
);

has grammar =>
(
	default  => sub {return ''},
	is       => 'rw',
	isa      => Any,
	required => 0,
);

has re =>
(
	default  => sub {return ''},
	is       => 'rw',
	isa      => Any,
	required => 0,
);

has recce =>
(
	default  => sub{return ''},
	is       => 'rw',
	isa      => Any,
	required => 0,
);

has test_count =>
(
	default  => sub{return 0},
	is       => 'rw',
	isa      => Int,
	required => 0,
);

has tree =>
(
	default  => sub{return Tree -> new('Root')},
	is       => 'rw',
	isa      => Any,
	required => 0,
);

has uid =>
(
	default  => sub {return 0},
	is       => 'rw',
	isa      => Int,
	required => 0,
);

has verbose =>
(
	default  => sub {return 0},
	is       => 'rw',
	isa      => Int,
	required => 0,
);

has warning_str =>
(
	default  => sub {return ''},
	is       => 'rw',
	isa      => Str,
	required => 0,
);

our $VERSION = '1.03';

# ------------------------------------------------

sub BUILD
{
	my($self)	= @_;
	my($bnf)	= get_data_section('V 5.20');

	$self -> bnf($bnf);
	$self -> grammar
	(
		Marpa::R2::Scanless::G -> new
		({
			source => \$self -> bnf
		})
	);
	$self -> reset;

} # End of BUILD.

# ------------------------------------------------

sub append
{
	my($self, %opts) = @_;

	for my $param (qw/text uid/)
	{
		die "Method append() takes a hash with these keys: text, uid\n" if (! defined($opts{$param}) );
	}

	my($meta);
	my($uid);

	for my $node ($self -> tree -> traverse)
	{
		next if ($node -> is_root);

		$meta	= $node -> meta;
		$uid	= $$meta{uid};

		if ($opts{uid} == $uid)
		{
			$$meta{text} .= $opts{text};
		}
	}

} # End of append.

# ------------------------------------------------

sub _add_daughter
{
	my($self, $event_name, $attributes)	= @_;
	$$attributes{uid}					= $self -> uid($self -> uid + 1);
	my($node)							= Tree -> new($event_name);

	$node -> meta($attributes);

	if ($event_name =~ /^close_(?:bracket|parenthesis)$/)
	{
		$self -> current_node($self -> current_node -> parent);
	}

	$self -> current_node -> add_child($node);

	if ( ($event_name =~ /^open_(?:bracket|parenthesis)$/) || ($event_name =~ /_prefix$/) )
	{
		$self -> current_node($node);
	}

} # End of _add_daughter.

# ------------------------------------------------

sub as_string
{
	my($self)	= @_;
	my($string)	= '';

	my($meta);

	for my $node ($self -> tree -> traverse)
	{
		next if ($node -> is_root);

		$meta	= $node -> meta;
		$string .= $$meta{text};
	}

	return $string;

} # End of as_string.

# ------------------------------------------------

sub find
{
	my($self, $target) = @_;

	die "Method find() takes a defined value as the parameter\n" if (! defined $target);

	my(@found);
	my($meta);

	for my $node ($self -> tree -> traverse)
	{
		next if ($node -> is_root);

		$meta = $node -> meta;

		if (index($$meta{text}, $target) >= 0)
		{
			push @found, $$meta{uid};
		}
	}

	return [@found];

} # End of find.

# ------------------------------------------------

sub get
{
	my($self, $wanted_uid)	= @_;
	my($max_uid)			= $self -> uid;

	if (! defined($wanted_uid) || ($wanted_uid < 1) || ($wanted_uid > $self -> uid) )
	{
		die "Method get() takes a uid parameter in the range 1 .. $max_uid\n";
	}

	my($meta);
	my($text);
	my($uid);

	for my $node ($self -> tree -> traverse)
	{
		next if ($node -> is_root);

		$meta	= $node -> meta;
		$uid	= $$meta{uid};

		if ($wanted_uid == $uid)
		{
			$text = $$meta{text};
		}
	}

	return $text;

} # End of get.

# ------------------------------------------------

sub _next_few_chars
{
	my($self, $stringref, $offset) = @_;
	my($s) = substr($$stringref, $offset, 20);
	$s     =~ tr/\n/ /;
	$s     =~ s/^\s+//;
	$s     =~ s/\s+$//;

	return $s;

} # End of _next_few_chars.

# ------------------------------------------------

sub parse
{
	my($self, %opts) = @_;

	# Emulate parts of new(), which makes things a bit earier for the caller.

	$self -> re($opts{re})				if (defined $opts{re});
	$self -> verbose($opts{verbose})	if (defined $opts{verbose});
	$self -> warning_str('');

	$self -> recce
	(
		Marpa::R2::Scanless::R -> new
		({
			exhaustion	=> 'event',
			grammar		=> $self -> grammar,
		})
	);

	# Return 0 for success and 1 for failure.

	my($result) = 0;

	my($message);

	try
	{
		if (defined (my $value = $self -> _process) )
		{
			$self -> print_cooked_tree if ($self -> verbose > 1);
		}
		else
		{
			$result = 1;

			my($message) = 'Error: Marpa parse failed. ';

			print $message, "\n" if ($self -> verbose);

			die $message;
		}
	}
	catch
	{
		die $_;
	};

	# Return 0 for success and 1 for failure.

	return $result;

} # End of parse.

# ------------------------------------------------

sub prepend
{
	my($self, %opts) = @_;

	for my $param (qw/text uid/)
	{
		die "Method append() takes a hash with these keys: text, uid\n" if (! defined($opts{$param}) );
	}

	my($meta);
	my($uid);

	for my $node ($self -> tree -> traverse)
	{
		next if ($node -> is_root);

		$meta	= $node -> meta;
		$uid	= $$meta{uid};

		if ($opts{uid} == $uid)
		{
			$$meta{text} = "$opts{text}$$meta{text}";
		}
	}

} # End of prepend.

# ------------------------------------------------

sub _process
{
	my($self)		= @_;
	my($raw_re)		= $self -> re;
	my($test_count)	= $self -> test_count($self -> test_count + 1);

	# This line is 'print', not 'say'!

	print "Test count: $test_count. Parsing (in qr/.../ form): " if ($self -> verbose);

	my($string_re)	= $self -> _string2re($raw_re);

	if ($string_re eq '')
	{
		print "\n" if ($self -> verbose);

		return undef;
	}

	print "'$string_re'. \n" if ($self -> verbose);

	if ($self -> verbose > 1)
	{
		my($format) = "%-10s  %-5s  %-20s  %-6s  %-30s  %s \n";

		print sprintf($format, '  Location', 'Width', 'Lexeme', 'Events', 'Names', 'Next few chars');

	}

	my($ref_re)		= \"$string_re"; # Use " in comment for UltraEdit.
	my($length)		= length($string_re);

	my($child);
	my($event_name);
	my($lexeme);
	my($pos);
	my($span, $start);

	# We use read()/lexeme_read()/resume() because we pause at each lexeme.

	for
	(
		$pos = $self -> recce -> read($ref_re);
		($pos < $length);
		$pos = $self -> recce -> resume($pos)
	)
	{
		($start, $span)				= $self -> recce -> pause_span;
		($event_name, $span, $pos)	= $self -> _validate_event($ref_re, $start, $span, $pos,);

		# If the input is exhausted, we exit immediately so we don't try to use
		# the values of $start, $span or $pos. They are ignored upon exit.

		last if ($event_name eq "'exhausted"); # Yes, it has a leading quote.

		$lexeme	= $self -> recce -> literal($start, $span);
		$pos	= $self -> recce -> lexeme_read($event_name);

		die "Marpa lexeme_read($event_name) rejected lexeme '$lexeme'\n" if (! defined $pos);

		$self -> _add_daughter($event_name, {text => $lexeme});
   }

	my($message);

	if (my $status = $self -> recce -> ambiguous)
	{
		my($terminals)	= $self -> recce -> terminals_expected;
		$terminals		= ['(None)'] if ($#$terminals < 0);
		$message		= "Marpa warning. Parse ambiguous. Status: $status. Terminals expected: " . join(', ', @$terminals);
	}
	elsif ($self -> recce -> exhausted)
	{
		# Special case. Sigh. I need to patch the BNF to do this. TODO.

		if ( ($pos + 1 == $length) && (substr($string_re, $pos, 1) eq ')') )
		{
			$self -> _add_daughter('close_parenthesis', {text => ')'});
		}

		# See https://metacpan.org/pod/distribution/Marpa-R2/pod/Exhaustion.pod#Exhaustion
		# for why this code is exhaustion-loving.

		$message = 'Marpa parse exhausted' if ($self -> verbose > 1);
	}

	if ($message)
	{
		$self -> warning_str($message);

		print $message, "\n" if ($self -> verbose);
	}

	$self -> print_raw_tree if ($self -> verbose);

	# Return a defined value for success and undef for failure.

	return $self -> recce -> value;

} # End of _process.

# ------------------------------------------------

sub print_cooked_tree
{
	my($self)	= @_;
	my($format)	= "%-30s  %3s  %s \n";

	print sprintf($format, 'Name', 'Uid', 'Text');
	print sprintf($format, '----', '---', '----');

	my($meta);

	for my $node ($self -> tree -> traverse)
	{
		next if ($node -> is_root);

		$meta = $node -> meta;

		print sprintf($format, $node -> value, $$meta{uid}, $$meta{text});
	}

} # End of print_cooked_tree.

# ------------------------------------------------

sub print_raw_tree
{
	my($self) = @_;

	print map("$_\n", @{$self -> tree -> tree2string});

} # End of print_raw_tree.

# ------------------------------------------------

sub reset
{
	my($self) = @_;

	$self -> tree(Tree -> new('Root') );
	$self -> tree -> meta({text => 'Root', uid => 0});
	$self -> current_node($self -> tree);
	$self -> uid(0);
	$self -> warning_str('');

} # End of reset.

# ------------------------------------------------

sub search
{
	my($self, $target) = @_;

	die "Method search() takes a defined value as the parameter\n" if (! defined $target);

	my($re) = $self -> _string2re($target);

	my(@found);
	my($meta);

	for my $node ($self -> tree -> traverse)
	{
		next if ($node -> is_root);

		$meta = $node -> meta;

		if ($$meta{text} =~ $re)
		{
			push @found, $$meta{uid};
		}
	}

	return [@found];

} # End of search.

# ------------------------------------------------

sub set
{
	my($self, %opts) = @_;

	for my $param (qw/text uid/)
	{
		die "Method set() takes a hash with these keys: text, uid\n" if (! defined($opts{$param}) );
	}

	my($meta);
	my($uid);

	for my $node ($self -> tree -> traverse)
	{
		next if ($node -> is_root);

		$meta	= $node -> meta;
		$uid	= $$meta{uid};

		if ($opts{uid} == $uid)
		{
			$$meta{text} = $opts{text};
		}
	}

} # End of set.

# ------------------------------------------------

sub _string2re
{
	my($self, $raw_re) = @_;

	my($re);

	try
	{
		$re = does($raw_re, 'Regexp') ? $raw_re : qr/$raw_re/;
	}
	catch
	{
		my($message) = "Error: Perl cannot convert $raw_re into qr/.../ form";

		print $message, "\n" if ($self -> verbose);

		die $message;
	};

	return $re;

} # End of _string2re.

# ------------------------------------------------

sub validate
{
	my($self)	= @_;
	my($re)		= $self -> as_string;

	my($result);

	try
	{
		$result = ('x' =~ $re) ? 0 : 0; # Use any test to force Perl to process the Regexp.
	}
	catch
	{
		$result = 1; # Failure.
	};

	# Return 0 for success and 1 for failure.

	return $result;

} # End of validate.

# ------------------------------------------------

sub _validate_event
{
	my($self, $stringref, $start, $span, $pos) = @_;
	my(@event)			= @{$self -> recce -> events};
	my($event_count)	= scalar @event;
	my(@event_names)	= sort map{$$_[0]} @event;
	my($event_name)		= $event_names[0]; # Default.

	# Handle some special cases.

	if ($event_count > 1)
	{
		my($event_list) = join(', ', @event_names);

		if ($event_list eq 'caret, string')
		{
			$event_count	= 1;
			$event_name		= 'caret';
			@event_names	= $event_name;
			$pos			= $start;
			$span			= 1;
		}
		elsif ($event_list eq 'query, string')
		{
			$event_count	= 1;
			$event_name		= 'query';
			@event_names	= $event_name;
			$pos			= $start;
			$span			= 1;
		}
		elsif ($event_list eq 'string, vertical_bar')
		{
			$event_count	= 1;
			$event_name		= 'vertical_bar';
			@event_names	= $event_name;
			$pos			= $start;
			$span			= 1;
		}
		else
		{
			#$self -> print_cooked_tree;

			die "event_count: $event_count. " . $event_list;
		}
	}

	# If the input is exhausted, we return immediately so we don't try to use
	# the values of $start, $span or $pos. They are ignored upon return.

	if ($event_name eq "'exhausted") # Yes, it has a leading quote.
	{
		return ($event_name, $span, $pos);
	}

	my($lexeme)			= substr($$stringref, $start, $span);
	my($line, $column)	= $self -> recce -> line_column($start);
	my($literal)		= $self -> _next_few_chars($stringref, $start + $span);
	my($message)		= "Location: ($line, $column). Lexeme: $lexeme. Events: $event_count. Names: ";
	my($name_list)		= join(', ', @event_names);
	$message			.= ". Next few chars: $literal";

	if ($self -> verbose > 1)
	{
		my($format) = "%4d, %4d  %5d  %-20s  %6d  %-30s  %s \n";

		print sprintf($format, $line, $column, length($lexeme), $lexeme, $event_count, $name_list, $literal);

	}

	return ($event_name, $span, $pos);

} # End of _validate_event.

# ------------------------------------------------

1;

=pod

=head1 NAME

C - Parse a Perl regexp into a data structure of type L

Warning: Development version. See L for details.

=head1 Synopsis

=head2 Sample Code

This is scripts/synopsis.pl:

	#!/usr/bin/env perl

	use v5.10;
	use strict;
	use warnings;

	use Regexp::Parsertron;

	# ---------------------

	my($re)     = qr/Perl|JavaScript/i;
	my($parser) = Regexp::Parsertron -> new(verbose => 1);

	# Return 0 for success and 1 for failure.

	my($result)  = $parser -> parse(re => $re);
	my($node_id) = 5; # Obtained from displaying and inspecting the tree.

	print "Calling append(text => '|C++', uid => $node_id) \n";

	$parser -> append(text => '|C++', uid => $node_id);
	$parser -> print_raw_tree;
	$parser -> print_cooked_tree;

	my($as_string) = $parser -> as_string;

	print "Original:    $re. Result: $result (0 is success) \n";
	print "as_string(): $as_string \n";

	$result = $parser -> validate;

	print "validate():  Result: $result (0 is success) \n";

	# Return 0 for success and 1 for failure.

	$parser -> reset;
	$parser -> verbose(0);

	$re     = qr/Perl|JavaScript|(?:Flub|BCPL)/i;
	$result = $parser -> parse(re => $re);

	print "\nAdd complexity to the regexp by parsing a new regexp \n";

	$parser -> print_raw_tree;

And its output:

	Test count: 1. Parsing (in qr/.../ form): '(?^i:Perl|JavaScript)'.
	Root. Attributes: {text => "Root", uid => "0"}
	    |--- open_parenthesis. Attributes: {text => "(", uid => "1"}
	    |    |--- query_caret. Attributes: {text => "?^", uid => "2"}
	    |    |--- flag_set. Attributes: {text => "i", uid => "3"}
	    |    |--- colon. Attributes: {text => ":", uid => "4"}
	    |    |--- string. Attributes: {text => "Perl|JavaScript", uid => "5"}
	    |--- close_parenthesis. Attributes: {text => ")", uid => "6"}

	Calling append(text => '|C++', uid => 5)
	Root. Attributes: {text => "Root", uid => "0"}
	    |--- open_parenthesis. Attributes: {text => "(", uid => "1"}
	    |    |--- query_caret. Attributes: {text => "?^", uid => "2"}
	    |    |--- flag_set. Attributes: {text => "i", uid => "3"}
	    |    |--- colon. Attributes: {text => ":", uid => "4"}
	    |    |--- string. Attributes: {text => "Perl|JavaScript|C++", uid => "5"}
	    |--- close_parenthesis. Attributes: {text => ")", uid => "6"}

	Name                            Uid  Text
	----                            ---  ----
	open_parenthesis                  1  (
	query_caret                       2  ?^
	flag_set                          3  i
	colon                             4  :
	string                            5  Perl|JavaScript|C++
	close_parenthesis                 6  )
	Original:    (?^i:Perl|JavaScript). Result: 0 (0 is success)
	as_string(): (?^i:Perl|JavaScript|C++)
	validate():  Result: 0 (0 is success)

	Adding complexity to the regexp by parsing a new regexp:
	Root. Attributes: {text => "Root", uid => "0"}
	    |--- open_parenthesis. Attributes: {text => "(", uid => "1"}
	    |    |--- query_caret. Attributes: {text => "?^", uid => "2"}
	    |    |--- flag_set. Attributes: {text => "i", uid => "3"}
	    |    |--- colon. Attributes: {text => ":", uid => "4"}
	    |    |--- string. Attributes: {text => "Perl|JavaScript|", uid => "5"}
	    |    |--- colon_prefix. Attributes: {text => "(?:", uid => "6"}
	    |    |    |--- string. Attributes: {text => "Flub|BCPL", uid => "7"}
	    |    |--- close_parenthesis. Attributes: {text => ")", uid => "8"}
	    |--- close_parenthesis. Attributes: {text => ")", uid => "9"}


Note: The 1st tree is printed due to verbose => 1 in the call to L, while the 2nd
is due to the call to L. The columnar output is due to the call to
L.

=head2 Tutorial

=over 4

=item o Start with a simple program and a simple regexp

This code, scripts/tutorial.pl, is a cut-down version of scripts/synopsis.pl:

	#!/usr/bin/env perl

	use v5.10;
	use strict;
	use warnings;

	use Regexp::Parsertron;

	# ---------------------

	my($re)     = qr/Perl|JavaScript/i;
	my($parser) = Regexp::Parsertron -> new(verbose => 1);

	# Return 0 for success and 1 for failure.

	my($result) = $parser -> parse(re => $re);

	print "Original:  $re. Result: $result. (0 is success) \n";

Running it outputs:

	Test count: 1. Parsing (in qr/.../ form): '(?^i:Perl|JavaScript)'.
	Root. Attributes: {text => "Root", uid => "0"}
	    |--- open_parenthesis. Attributes: {text => "(", uid => "1"}
	    |    |--- query_caret. Attributes: {text => "?^", uid => "2"}
	    |    |--- flag_set. Attributes: {text => "i", uid => "3"}
	    |    |--- colon. Attributes: {text => ":", uid => "4"}
	    |    |--- string. Attributes: {text => "Perl|JavaScript", uid => "5"}
	    |--- close_parenthesis. Attributes: {text => ")", uid => "6"}

	Original:  (?^i:Perl|JavaScript). Result: 0. (0 is success)

=item o Examine the tree and determine which nodes you wish to edit

The nodes are uniquely identified by their uids.

=item o Proceed as does scripts/synopsis.pl

Add these lines to the end of the tutorial code, and re-run:

	my($node_id) = 5; # Obtained from displaying and inspecting the tree.

	$parser -> append(text => '|C++', uid => $node_id);
	$parser -> print_raw_tree;

The extra output, showing the change to node uid == 5, is:

	Root. Attributes: {text => "Root", uid => "0"}
	    |--- open_parenthesis. Attributes: {text => "(", uid => "1"}
	    |    |--- query_caret. Attributes: {text => "?^", uid => "2"}
	    |    |--- flag_set. Attributes: {text => "i", uid => "3"}
	    |    |--- colon. Attributes: {text => ":", uid => "4"}
	    |    |--- string. Attributes: {text => "Perl|JavaScript|C++", uid => "5"}
	    |--- close_parenthesis. Attributes: {text => ")", uid => "6"}

=item o Test also with L and L

See t/get.set.t for sample code.

=item o Since everything works, make a cup of tea

=back

=head2 The Edit Methods

The I simply means any one or more of these methods, which can all change the text of
a node:

=over 4

=item o L

=item o L

=item o L

=back

The edit methods are exercised in t/get.set.t, as well as scripts/synopsis.pl (above).

=head1 Description

Parses a regexp into a tree object managed by the L module, and provides various methods for
updating and retrieving that tree's contents.

This module uses L and L.

=head1 Distributions

This module is available as a Unix-style distro (*.tgz).

See L
for help on unpacking and installing distros.

=head1 Installation

Install C as you would any C module:

Run:

	cpanm Regexp::Parsertron

or run:

	sudo cpan Regexp::Parsertron

or unpack the distro, and then use:

	perl Makefile.PL
	make (or dmake or nmake)
	make test
	make install

=head1 Constructor and Initialization

C is called as C<< my($parser) = Regexp::Parsertron -> new(k1 => v1, k2 => v2, ...) >>.

It returns a new object of type C.

Key-value pairs accepted in the parameter list (see corresponding methods for details
[e.g. L]):

=over 4

=item o re => $regexp

The C method of L is called to see what C is. If it's already of the
form C, then it's processed as is, but if it's not, then it's transformed using C.

Warning: Currently, the input is expected to have been pre-processed by Perl via qr/$regexp/.

Default: ''.

=item o verbose => $integer

Takes values 0, 1 or 2, which print more and more progress reports.

Used for debugging.

Default: 0 (print nothing).

=back

=head1 Methods

=head2 append(%opts)

Append some text to the text of a node.

%opts is a hash with these (key => value) pairs:

=over 4

=item o text => $string

The text to append.

=item o uid => $uid

The uid of the node to update.

=back

The code calls C if %opts does not have these 2 keys, or if either value is undef.

See scripts/synopsis.pl for sample code.

Note: Calling C never changes the uids of nodes, so repeated calling of C with
the same C will apply more and more updates to the same node.

See also L, L and t/get.set.t.

=head2 as_string()

Returns the parsed regexp as a string. The string contains all edits applied with
L.

=head2 find($target)

Returns an arrayref of node uids whose text contains the given string.

If the arrayref is empty, there were no matches.

The Perl function C is used here to test for $target being a substring of the text
associated with each node.

The code calls C if $target is undef.

See t/get.set.t for sample usage of C.

See L for a regexp-based test. See also L.

=head2 get($uid)

Get the text of the node with the given $uid.

The code calls C if $uid is undef, or outside the range 1 .. $self -> uid. The latter value
is the highest uid so far assigned to any node.

Returns undef if the given $uid is not found.

See also L.

=head2 new([%opts])

Here, '[]' indicate an optional parameter.

See L for details on the parameters accepted by L.

=head2 parse([%opts])

Here, '[]' indicate an optional parameter.

Parses the regexp supplied with the parameter C in the call to L or in the call to
L, or in the call to C<< parse(re => $regexp) >> itself. The latter takes precedence.

The hash C<%opts> takes the same (key => value) pairs as L does.

See L for details.

=head2 prepend(%opts)

Prepend some text to the text of a node.

%opts is a hash with these (key => value) pairs:

=over 4

=item o text => $string

The text to prepend.

=item o uid => $uid

The uid of the node to update.

=back

The code calls C if %opts does not have these 2 keys, or if either value is undef.

Note: Calling C never changes the uids of nodes, so repeated calling of C with
the same C will apply more and more updates to the same node.

See also L, L, and t/get.set.t.

=head2 print_cooked_tree()

Prints, in a pretty format, the tree built from parsing.

See the  for sample output.

See also L.

=head2 print_raw_tree()

Prints, in a simple format, the tree built from parsing.

See the  for sample output.

See also L.

=head2 re([$regexp])

Here, '[]' indicate an optional parameter.

Gets or sets the regexp to be processed.

Note: C is a parameter to L.

=head2 reset()

Resets various internal things, except test_count.

Used basically for debugging.

=head2 search($target)

Returns an arrayref of node uids whose text contains the given string.

If the arrayref is empty, there were no matches.

$target is converted to a regexp if a simple string is passed in.

The code calls C if $target is undef.

See t/search.t for sample usage of C.

See L for a non-regexp search. See also L.

=head2 set(%opts)

Set the text of a node to $opt{text}.

%opts is a hash with these (key => value) pairs:

=over 4

=item o text => $string

The text to use to overwrite the text of the node.

=item o uid => $uid

The uid of the node to update.

=back

The code calls C if %opts does not have these 2 keys, or if either value is undef.

See also L and L.

=head2 tree()

Returns an object of type L. Ignore the root node.

Each node's C method returns a hashref of information about the node. See the
L for details.

See also the source code for L and L for ideas on how to
use this object.

=head2 uid()

Returns the last-used uid.

Each node in the tree is given a uid, which allows methods like L to work.

=head2 verbose([$integer])

Here, '[]' indicate an optional parameter.

Gets or sets the verbosity level, within the range 0 .. 2. Higher numbers print more progress
reports.

Used basically for debugging.

Note: C is a parameter to L.

=head2 warning_str()

Returns the last Marpa warning.

In short, Marpa will always report 'Marpa parse exhausted' in warning_str() if the parse is not
ambiguous, but do not worry - I.

See L and
L.

=head1 FAQ

=head2 Can I add a subtree to the tree?

Not yet.

There is a private method, C<_add_daughter()>, which I could make public, if I felt it was safe to
do so.

=head2 Why does the BNF not accept an empty regexp?

Simple answer: Changing the BNF to handle this creates a massive problem elsewhere in the BNF.

Complex answer:

The BNF contains this countable rule to allow patterns to be juxtaposed without '|', say, to
separate them:

	global_sequence ::= pattern_type+

And in turn (further toward the leaves of the tree of BNF), I then use:

	pattern_sequence ::= pattern_set+

To allow an empty regexp would mean changing this rule to:

	pattern_sequence ::= pattern_set*

But that makes this rule nullable, and Marpa rejects the C rule on the grounds that
a countable rule is not allowed to be nullable. ATM I cannot see a way of
rewriting the rules to avoid this problem. But I'm hopeful such a rewrite is possible.

=head2 Why does the code sometimes not store '|' - as in qr/(Perl|JavaScript/) - in its own node?

It could be done by, for example, splitting such a string into three nodes, 'Perl', '|',
'Javascript'. But does that offer any benefit?

It makes processing by the user more complex because then if they wish to edit the list of
alternatives, they might have to edit two or three nodes instead of one. Here, editing means perhaps
replacing any existing string with the empty string.

Further, to extend the list of alternatives, the user will be confused by not being sure if they
should change 'Javascript' to 'Javascript|C' or if they have to add two nodes, containing '|' and
'C'. And ATM adding nodes is contraindicated!

Despite this, when the input stream triggers two events, C and C,
simultaneously because the '|' is at the start of a string, special code in the private method
C<_validate_event()> does put '|' in its own node. IOW the BNF does not do the work, which is really
what I would prefer.

=head2 Does this module ever use \Q...\E to quote regexp metacharacters?

No.

=head2 What is the format of the nodes in the tree built by this module?

Each node's C is the name of the Marpa-style event which was triggered by detection of
some C within the regexp.

Each node's C method returns a hashref with these (key => value) pairs:

=over 4

=item o text => $string

This is the text within the regexp which triggered the event just mentioned.

=item o uid => $integer

This is the unique id of the 'current' node.

This C is often used by you to specify which node to work on.

See t/get.set.t and t/simple.t for sample code.

The code never changes the uid of a node.

=back

See also the source code for L and L for ideas on how to
use the tree.

See the L for sample code and a report after parsing a tiny regexp.

=head2 Does the root node in the tree ever hold useful information?

No. Always ignore it.

=head2 Why does the BNF never use the lexeme adverb C?

Because with Marpa::R2 the priority is only used when lexemes are the same length.

L.

=head2 Does this module interpret regexps in any way?

No. You have to run your own Perl code to do that. This module just parses them into a data
structure.

And that really means this module does not match the regexp against anything. If I appear to do that
while debugging new code, you can't rely on that appearing in production versions of the module.

=head2 Does this module rewrite regexps?

No, unless you call one of L.

=head2 Does this module handle both Perl 5 and Perl 6?

No. It will only handle Perl 5 syntax.

=head2 Does this module handle regexps for various versions of Perl5?

Not yet. Version-dependent regexp syntax will be supported for recent versions of Perl. This is
done by having tokens within the BNF which are replaced at start-up time with version-dependent
details.

There are no such tokens at the moment.

All debugging is done assuming the regexp syntax as documented online. See L for the
urls in question.

=head2 So which version of Perl is supported?

The code is expected to work for Perls back to V 5.14.0, which is when stringification of regexps
changed. See L below for more.

I'm (2018-01-14) using Perl V 5.20.2 and making the BNF match the Perl regexp docs listed in
L below.

The program t/perl-5.21.11.t reads the file 'xt/author/re_tests' which I copied from the source code
of Perl V 5.21.11. This test is the one which currently provides 858 passing tests out of the 1027
tests which pass for me using prove -lv t.

=head2 Could Perl and this module generate different parses of the same regexp?

Absolutely! There is no escape from this fact simply because the code used in each program bears no
relationship to the code in the other one.

The real question is: How do we make the code in each program accept and reject exactly the same
regexps as the code in the other program. I think trial-and-error is all we have available to us for
dealing with this issue.

=head2 After calling parse(), warning_str() contains the string '... Parse ambiguous ...'

This is almost certainly a error with the BNF, although of course it may be an error will an
exceptionally-badly formed regexp.

Report it via L, and please
 include the regexp in the report. Thanx!

=head2 Is this a (Marpa) exhaustion-hating or exhaustion-loving app?

Exhaustion-loving.

See L

=head2 Will this code be modified to run under Marpa::R3 when the latter is stable?

Yes.

=head2 What is the purpose of this module?

=over 4

=item o To provide a stand-alone parser for regexps

=item o To help me learn more about regexps

=item o To become, I hope, a replacement for the horrendously complex L

=back

=head2 Who crafted the BNF?

I did.

=head1 Scripts

This diagram indicates the flow of logic from script to script:

	xt/author/re_tests
	|
	V
	xt/author/generate.tests.pl
	|
	V
	xt/authors/perl-5.21.11.tests
	|
	V
	perl -Ilib t/perl-5.21.11.t > xt/author/perl-5.21.11.log 2>&1

If xt/author/perl-5.21.11.log only contains lines starting with 'ok', then all Perl and Marpa
errors have been hidden, so t/perl-5.21.11.t is ready to live in t/. Before that time it lives in
xt/author/.

=head1 TODO

=over 4

=item o How to best define 'code' in the BNF.

=item o I could traverse the tree and store a pointer to each node in an array

This would mean fast access to nodes in random order. But is there any point? Yes, it would speed up
various methods. Specifically, any module which calls C on the tree object would
benefit.

=item o Allow users to add nodes and hence subtrees to the tree

=back

=head1 References

L. PCRE - Perl Compatible Regular Expressions.

L. This is the definitive document.

L.

L. Samples with commentary.

L

L

L

L. This is when stringification
changed to return (?^...) rather than (?-xism...).

L

L. Regular Expression
Inconsistencies With Unicode.

L

L

L

=head1 See Also

L

L

L

L

L

L

L

L

L

L. This is vaguely a version of L.

L

L

And many others...

=head1 Machine-Readable Change Log

The file Changes was converted into Changelog.ini by L.

=head1 Version Numbers

Version numbers < 1.00 represent development versions. From 1.00 up, they are production versions.

=head1 CPAN Tester Results

L

=head1 Repository

L

=head1 Support

Email the author, or log a bug on RT:

L.

=head1 Author

L was written by Ron Savage [e-mail]> in 2011.

Marpa's homepage: L.

L.

=head1 Copyright

Australian copyright (c) 2016, Ron Savage.

	All Programs of mine are 'OSI Certified Open Source Software';
	you can redistribute them and/or modify them under the terms of
	The Artistic License 2.0, a copy of which is available at:
	http://opensource.org/licenses/alphabetical.

=cut

__DATA__