File Coverage

blib/lib/Perl6/Rules.pm

Criterion	Covered	Total	%
statement	40	632	6.3
branch	0	344	0.0
condition	0	174	0.0
subroutine	14	80	17.5
pod	0	2	0.0
total	54	1232	4.3

package Perl6::Rules;
use 5.008_003;
use re 'eval';
use Carp;
# use strict;
use charnames ':full';
use utf8;

our $VERSION = '0.03';

# Support for these properties on interpolated hashes...

our (%keymatch, %valuematch);

# Are we debugging or translating?

our ($debug, $translate) = (0,0);

# Did we get an error?

my $bad = 0;

# Turn off special $0 magic

*0 = \ my $zero;

# Reset state package variables
# (only used during filtering so no need for reentrancy)

our (@p5pat, $raw, %mod, @mark, @capindex, %caps, $nextcapindex, $rulename);
our $rule_id = 2;
our @rules = qr{(?{die "No successful  rule\n"})(?!)};
our $prior = 0;
our $has_prior;

sub new {
	@p5pat = "";
	$raw = "";
	%mod = (pre=>{}, post=>{});
	@mark = ();
	@capindex = ();
	%caps = ();
	$nextcapindex = 1;
	$rulename = "";
	$has_prior = 0;
}


# Use this sub instead of C, so as to allow multiple error
# messages before dying...

sub error {
	print {*STDERR} @_, "\n";
	$bad++;
}


# Print debug info only if debugging...

sub debug {
	return unless $debug;
	my $mesg = join "", map { defined $_ ? $_ : ''} @_;
	$mesg .= "\n" unless substr($mesg,-1) eq "\n";
	print STDERR $mesg;
}

sub add_debug {
    my $what = quotemeta $_[1];
    $_[0] = "(?:(?{print STDERR qq{Trying $what...\\n}})"
          . $_[0]
          . "(?{print STDERR qq{...Matched $what\\n}}))"
        if $debug==1;   # Higher value indicates inside codeblock or assertion.
}

# Remember left delimiter and predict right delimiter...

our ($ldel, $rdel);

sub delim {
	($ldel, $rdel) = ($^N)x2;
	$rdel =~ tr/{[(/;
}


# Record another component of the raw Perl 6 pattern
# and add its back-translation to the Perl 5 pattern...

sub add {
	my ($p6pat, $p5pat) = @_;
	debug "Translating /$p6pat/ back to /$p5pat/\n";
	$raw .= $p5pat;
	add_debug $p5pat, "/$p6pat/";
	push @p5pat, $p5pat;
}


# Convert internal vars in subscripts from P6 to P5 syntax...

sub translate_vars_internal {
	my ($src) = @_;
	my ($next, $newsrc);
	while (1) {
		$next = index($src,'$?');
		$next = index($src,'@?') if $next < 0;
		$next = index($src,'%?') if $next < 0;
		if ($next < 0) {
			$newsrc .= $src;
			last;
		}
		$newsrc .= substr($src,0,$next,"");		# shift off and delete
		$next=2;
		while ($next < length $src) {
			my $char = lc substr($src,$next,1);
			last unless $char ge 'a' && $char le 'z'
						|| $char ge '0' && $char le '9'
						|| $char eq '_';
			$next++;
		}
		my $var = substr($src,0,$next,"");	# shift off and delete
		my $follow1 = substr($src,0,1);
		my $follow2 = substr($src,0,2);
		if (substr($var,0,2) eq '$?') {
			if ($follow2 eq '.{' || $follow2 eq '.[') {     #}]
				substr($src,0,1,"");			# delete optional dot
			}
			$newsrc .= "\$Perl6::Rules::d0{'$var'}";
		}
		elsif (substr($var,0,2) eq '@?') {
			if ($follow1 eq '[') {							#]
				$newsrc .= "\$Perl6::Rules::d0{'$var'}";
			}
			elsif ($follow2 eq '.[') {						#]
				$newsrc .= "\$Perl6::Rules::d0{'$var'}";
				substr($src,0,1,"");			# delete optional dot
			}
			else {
				$newsrc .= "\@{\$Perl6::Rules::d0{'$var'}}";
			}
		}
		else {   # %?var
			if ($follow1 eq '{') {							#}
				$newsrc .= "\$Perl6::Rules::d0{'$var'}";
			}
			elsif ($follow2 eq '.{') {						#}
				$newsrc .= "\$Perl6::Rules::d0{'$var'}";
				substr($src,0,1,"");			# delete optional dot
			}
			else {
				$newsrc .= "\%{\$Perl6::Rules::d0{'$var'}}";
			}
		}
	}
	return $newsrc;
}

# Record that next component of the raw Perl 6 pattern is an
# interpolated scalar, and add its back-translation to the Perl 5 pattern.
# This sub handles translation of both /$as_literal/ and /<$as_rules>/
# scalar interpolations...

sub addscalar_external {
	my ($var, $quotemeta) = @_;
	$quotemeta ||= "";

	# Record original...
	$raw .= $var;

	my $subscripts="";
	my ($p5pat, $subscriptpos);

	# Translate Perl6ish @array[...] or %hash{...}
	# to Perl5ish $array[...]/$hash{...}...
	my $special = substr($var,0,1);
	if ($special eq '@') {
		$subscriptpos = index($var,".[");
		$subscriptpos = index($var,"[") unless $subscriptpos > 0;
		$subscripts = translate_vars_internal substr($var,$subscriptpos);
		substr($var,$subscriptpos) = "";
		$p5pat = $subscripts ? '$' . substr($var,1) . $subscripts : $var;
	}
	elsif ($special eq '%') {
		$subscriptpos = index($var,".{");
		$subscriptpos = index($var,"{") unless $subscriptpos > 0;
		$subscripts = translate_vars_internal substr($var,$subscriptpos);
		substr($var,$subscriptpos) = "";
		$p5pat = $subscripts ? '$' . substr($var,1) . $subscripts : $var;
	}

	# Translate Perl6ish $ref.{...} to Perl5ish $ref->[...] ...
	elsif (($special = index($var,'.')) > 0) {
		$p5pat = substr($var,0,$special)
			   . "->"
			   . translate_vars_internal(substr($var,$special+1));
	}

	# Translate Perl6ish $ref{...} or $ref[...]
	# to Perl5ish $ref->{...} or $ref->[...]
	elsif (($special = index($var,'[')) > 0 or
	       ($special = index($var,'{')) > 0 ) {
		$p5pat = substr($var,0,$special)
			   . "->"
			   . translate_vars_internal(substr($var,$special));
	}
	else {
		$p5pat = $var;
	}

	# Quotemeta interpolation as required...
	$p5pat = $quotemeta eq 'rw' ? $p5pat : qq{(??{$quotemeta $p5pat})};

	# Insert debugging code if appropriate...
	add_debug $p5pat, "/$var/";

	# Add back-translation...
	my $what = $quotemeta ? "literal" : "pattern";
	debug "Adding $var (as $what interpolation)\n";

	push @p5pat, $p5pat;
}

sub addscalar_internal {
	my ($var, $quotemeta) = @_;
	$quotemeta ||= "";

	my $subscripts="";

	# Record original...
	$raw .= $var;

	my ($p5pat, $subscriptpos);

	# Translate Perl6ish @?array[...] or %?hash{...}
	my $special = substr($var,0,2);
	if ($special eq '@?') {
		$subscriptpos = index($var,".[");
		$subscriptpos = index($var,"[") unless $subscriptpos > 0;
		$subscripts = translate_vars_internal substr($var,$subscriptpos);
		substr($var,$subscriptpos) = "";
		$p5pat = $subscripts ? "\$Perl6::Rules::d0{q{$var}}->$subscripts"
						     : "\@{\$Perl6::Rules::d0{q{$var}}}";
	}
	elsif ($special eq '%?') {
		$subscriptpos = index($var,".{");
		$subscriptpos = index($var,"{") unless $subscriptpos > 0;
		$subscripts = translate_vars_internal substr($var,$subscriptpos);
		substr($var,$subscriptpos) = "";
		$p5pat = $subscripts ? "\$Perl6::Rules::d0{q{$var}}->$subscripts"
						     : "\%{\$Perl6::Rules::d0{q{$var}}}";
	}

	# Translate Perl6ish $ref.{...} to Perl5ish $ref->{...} ...
	elsif (($special = index($var,'.')) > 0) {
		$subscripts = substr($var,$special+1);
		$subscripts = translate_vars_internal $subscripts;
		substr($var,$special) = "";
		$p5pat = "\$Perl6::Rules::d0{q{$var}}->$subscripts";
	}

	# Translate Perl6ish $ref{...} or $ref[...]
	# to Perl5ish $ref->{...} or $ref->[...]
	elsif (($special = index($var,'[')) > 0 or
	       ($special = index($var,'{')) > 0 ) {
		$subscripts = translate_vars_internal substr($var,$special);
		substr($var,$special) = "";
		$p5pat = "\$Perl6::Rules::d0{q{$var}}->$subscripts";
	}
	else {
		$p5pat = "\$Perl6::Rules::d0{q{$var}}";
	}

	# Quotemeta interpolation as required...
	$p5pat = $quotemeta eq 'rw' ? $p5pat : qq{(??{$quotemeta $p5pat})};

	# Insert debugging code if appropriate...
	add_debug $p5pat, "/$var/";

	# Add back-translation...
	my $what = $quotemeta ? "literal" : "pattern";
	debug "Adding $var (as $what interpolation)\n";

	push @p5pat, $p5pat;
}


# Record that next component of the raw Perl 6 pattern is an
# interpolated array, and add its back-translation to the Perl 5 pattern.
# This sub handles translation of both /@::as_literals/ and /<@::as_rules>/
# array interpolations...

sub addarray_external {
	my ($var, $quotemeta) = @_;
	$quotemeta = $quotemeta ? "map $quotemeta," : "map \$_,";

	# Record original...
	$raw .= $var;

	# Expand elements of variable, conjoining with ORs...
	my $p5pat = qq{(??{join q{|}, $quotemeta $var})};
	add_debug $p5pat, "/$var/";

	# Insert debugging code if requested...
	my $what = $quotemeta eq 'map quotemeta,' ? "literal" : "pattern";

	# Add back-translation...
	debug "Adding $var (as $what interpolation)\n";
	push @p5pat, $p5pat;
}

sub addarray_internal {
	my ($var, $quotemeta) = @_;
	$quotemeta = $quotemeta ? "map $quotemeta," : "map \$_,";

	# Record original...
	$raw .= $var;

	# Expand elements of variable, conjoining with ORs...
	my $p5pat = qq{(??{join q{|}, $quotemeta \@{\$Perl6::Rules::d0{q{$var}}}})};
	add_debug $p5pat, "/$var/";

	# Insert debugging code if requested...
	my $what = $quotemeta eq 'map quotemeta,' ? "literal" : "pattern";

	# Add back-translation...
	debug "Adding $var (as $what interpolation)\n";
	push @p5pat, $p5pat;
}


sub addhash_internal {
	my ($var, $quotemeta) = @_;
	my $hashaccess = "getcap_name(q{$var})->";

	# Construct value matcher...
	# (Properties on internal hashes are not supported, so no
	#  need to test for keymatch or valuematch)
	my $valhandler = # Match one of the keys...
		   		     '(??{exists ' . $hashaccess . '{$^R} ? '
		   			 # and match against the corresponding value, or fail
		 		   . $hashaccess . '{$^R} : "(?!)"})'
		;

	# Construct the Perl 5 equivalent...
				# Match any of the hash's keys (or its keymatch property)...
	my $p5pat = '(?> ((?> \w+ )) (?{$^N})'
				# Then match the corresponding value (or valuematch property)...
		      . $valhandler . ')';

	# Insert debugging info if requested...
	my $what = $quotemeta ? "literal" : "pattern";

	# Add back-translation...
	debug "Adding $var (as $what interpolation)\n";
	add_debug $p5pat, "/$var/";
	push @p5pat, $p5pat;
}

sub addhash_external {
	my ($var, $quotemeta) = @_;

	# Record original...
	$raw .= $var;

	# Convert to Perl5 access syntax...
	my $hashaccess = '$'.substr($var,1);

	# Construct value matcher...
	my $valhandler = $quotemeta
		# If hash has properties controlling interpolation...
		?  '(??{exists ' . $hashaccess . '{$^N} ? "" : "(?!)"})'
		   # Get the specified value matcher and match with it...
		 . '((?> (??{Perl6::Rules::valuematch(\\' . $var. ')}) ))'
		   # Fail if no such specified value matcher or if it fails...
		 . '(??{!defined($^R)||' . $hashaccess . '{$^R} eq $^N ? "" : "(?!)"})'
		# Otherwise do normal hash interpolation...
		   # Match one of the keys...
		:  '(??{exists ' . $hashaccess . '{$^R} ? '
		   # and match against the corresponding value, or fail
		 . $hashaccess . '{$^R} : "(?!)"})'
		;

	# Construct the Perl 5 equivalent...
				# Match any of the hash's keys (or its keymatch property)...
	my $p5pat = '(?> ((?> (??{Perl6::Rules::keymatch(\\' . $var
			  . ')}) )) (?{$^N})'
				# Then match the corresponding value (or valuematch property)...
		      . $valhandler . ')';

	# Insert debugging info if requested...
	my $what = $quotemeta ? "literal" : "pattern";

	# Add back-translation...
	debug "Adding $var (as $what interpolation)\n";
	add_debug $p5pat, "/$var/";
	push @p5pat, $p5pat;
}

sub keymatch {
	my ($hashref) = @_;
	my $keymatch = exists $keymatch{$hashref}
		? eval $keymatch{$hashref}
		: qr{\w+};
	debug "Matching hash key with: $keymatch\n";
	return $keymatch;
}

sub valuematch {
	my ($hashref) = @_;
	return qr{(?{undef $^R})} unless exists $valuematch{$hashref};
	my $valuematch = eval $valuematch{$hashref};
	debug "Matching hash value with: $valuematch\n";
	return $valuematch;
}

our $wordsp = '(?:(?<=\w)(?:\s+(?=\w)|\s*(?=\W|\z))|(?<=\W)\s*|\A\s*)';
sub wordspace {
	return unless $mod{words};
	debug "Inserting space matching /$raw <-- HERE/\n";
	my $pat = '(??{$Perl6::Rules::wordsp})';
	add_debug $pat, "Skipping whitespace";
	push @p5pat, "(?:$pat)";
}

my @failure;
sub fallible { push @failure, 0 }
sub fail     { no warnings; debug "Failed"; $failure[-1] = 1; last FALLIBLE }
sub failed   { pop(@failure) ? '(?!)' : '' }

{ no strict 'refs'; *{caller()."::fail"} = \&fail; }

sub codeblock {
	my ($type, $nested) = @_;
	debug "Closed $type block";
	$raw .= $type;
	my $mark = pop @mark;
	my $code = join "", splice @p5pat, $mark, @p5pat-$mark;
	if ($nested) {
		push @p5pat, "{$code}";
		return;
	}
	$code = "do{$code}||fail" if $type eq ')>';
	debug "Translated $type block to '$code'";
	$code = "(??{Perl6::Rules::fallible;FALLIBLE:{$code}Perl6::Rules::failed})";
	add_debug $code, "codeblock";
	push @p5pat, $code;
}

sub alternative {
	$raw .= '|';
	push @p5pat, '|';
}

sub subrule {
	my ($subrule, $repeat, $capture, $negate) = @_;
	my $p6pat = "$subrule$repeat";
	$p6pat = "($p6pat)" if $capture;
	$raw .= $p6pat;
	$negate ||= "";

	my ($classname, $rulename);
	if ((my $index = index($subrule,'.'))>0) {
		$classname = substr($subrule,0,$index);
		$rulename  = substr($subrule,$index+1);
	}
	else {
		$classname = '__PACKAGE__';
		$rulename  = $subrule;
	}
	my $callrule;
	if ($rulename eq 'prior') {
		error "Don't know how to match inverted <-prior>" if $negate eq '-';
		$callrule = '(??{$Perl6::Rules::rules[$Perl6::Rules::prior]||"(?!)"})';
		$has_prior = 1;
	}
	elsif ($rulename eq 'self') {
		error "Don't know how to match inverted <-self>" if $negate eq '-';
		$callrule = "(?>(??{\$Perl6::Rules::rules[$rule_id]}))";
	}
	else {
		$callrule = $negate eq "-"
			?  "(??{$classname->can(q{$rulename})?$classname->$rulename(invert=>1):Perl6::Rules::stdrule(q{$subrule},1)})"
			: "(??{$classname->can(q{$rulename})?$classname->$rulename():Perl6::Rules::stdrule(q{$subrule})})";
	}
	$repeat = trans_repeat($repeat) if $repeat;

	# Save and restore match variables...

	$callrule = "(?:(?{local \%Perl6::Rules::d0 = \%Perl6::Rules::d0;local \@Perl6::Rules::d0 = \@Perl6::Rules::d0;Perl6::Rules::save_d0})$callrule(?{Perl6::Rules::restore_d0}))";

	my $storage = "\$Perl6::Rules::d0{q{\$?$rulename}}";
	if ($repeat && $capture) {
		push @p5pat, "(?{local $storage = []})(?:$callrule(?{Perl6::Rules::apparray([$storage], \$0)}))$repeat";
	}
	elsif ($repeat) {
		push @p5pat, "$callrule$repeat";
	}
	elsif ($capture) {
		push @p5pat, "($callrule)(?{local $storage = $storage; $storage = \$0})";
	}
	else {
		push @p5pat, $callrule;
	}
	if ($negate eq '!') {
		$p5pat[-1] = "(?!$p5pat[-1])";
	}
	add_debug $p5pat[-1], "/$p6pat/";
}

my %sigil = ( '$'=>1, '%'=>1, '@'=>1 );

sub trans_repeat {
	my ($rep) = @_;
	return "" unless $rep;
	my ($from, $to);
	if (substr($rep,0,1) eq '<') {
		my $comma = index $rep, ",";
		if ($comma > 0) {
			$from = substr($rep,1,$comma-1);
			chop($to = substr($rep,$comma+1));
			error "The use of variables in repetitions is not yet supported: <$from,$to>"
				if grep { $sigil{substr($_,0,1)} } $from, $to;
		}
		else {
			chop($from = substr($rep,1));
			$to   = $from;
			error "The use of variables in repetitions is not yet supported: <$from>"
				if $sigil{substr($from,0,1)};
		}
		#SHOULD BE: $from = "(??{$from})" if substr($from,0,1) eq '$';
		#SHOULD BE: $to   = "(??{$to})"   if substr($to,0,1) eq '$';
		$rep = "{$from,$to}";
	}
	return $rep;
}

sub nobacktrack {
	$p5pat[-1] = "(?>$p5pat[-1])";
}

sub repeat {
	$raw .= $^N;
	my $rep = trans_repeat($^N);
	$p5pat[-1] = "(?:$p5pat[-1])" if length($p5pat[-1]||"") > 1;
	$p5pat[-1] .= $rep;
}

sub setcapindex {
	$nextcapindex = shift;
}

sub capmark {
	my ($name) = @_;
	my $sigil = @capindex ? substr($capindex[-1],0,1) : "";
	push @capindex, ($name ? $name : $nextcapindex++)
		  unless $sigil && ($sigil eq '@' || $sigil eq '%');
	push @mark, scalar @p5pat;
	$raw .= "$name := " if $name;
	$raw .= '(';
}

sub mark {
	my ($type) = @_;
	debug "Opening $type block\n";
	push @mark, scalar @p5pat;
	$raw .= $type;
}

sub lookaround {
	my ($type) = @_;
	my $mark = pop @mark;
	splice @p5pat, $mark, @p5pat-$mark, "$type@p5pat[$mark..$#p5pat])";
	$raw .= '>';
}

sub make_charset {
	$raw .= '>';
	my $mark = pop @mark;
	my (@neg, @pos);
	for (splice @p5pat, $mark, @p5pat-$mark) {
		push @neg, @{$_->[0]};
		push @pos, @{$_->[1]};
	}
	push @p5pat, '(?:';
	$p5pat[-1] .= join "", map "(?!$_)", @neg if @neg;
	$p5pat[-1] .= @pos ? '(?:' . join('|', @pos) . ')' : '(?s:.)';
	$p5pat[-1] .= ')';
	debug "Emitted char class: /$p5pat[-1]/\n";
}

sub capture_internal {
	return unless @mark;    # Implies unbalanced closing paren
	my $index = $capindex[-1];
	my $sigil = substr($index,0,1);
	my $subsigil = substr($index,1,1);
	goto &capture_external if $subsigil ne '?';
	$raw .= ')';
	my $mark = pop @mark;
	pop @capindex unless $sigil eq '@' || $sigil eq '%';
	my $action;
	my $storage = "\$Perl6::Rules::d0{q{$index}}";
	if ($sigil eq '$') {
		$action = "local $storage = \$^N";
	}
	elsif ($sigil eq '@') {
		$action = "local $storage = $storage; Perl6::Rules::apparray($storage, \$^N)";
	}
	elsif ($sigil eq '%') {
		$action = "local $storage = $storage; Perl6::Rules::apphash($storage, \$^N)";
	}
	else {
		$action = "local \$Perl6::Rules::d0[$index] = \$^N";
	}
	splice @p5pat, $mark, @p5pat-$mark, "(@p5pat[$mark..$#p5pat])(?{$action})";
}

# Translate \c[...] and \C[...] back to Perl5ish \N{...} and [^\N{...}]

my %trans = (
	'\c' => sub { '(?-x:\N{'.$_.'})' },
	'\C' => sub { '(?s-x:(?!\N{'.$_.'}).)' },
	'\x' => sub { sprintf '\x{%0.4s}', $_ },
	'\X' => sub { sprintf '[^\x{%0.4s}]', $_ },
	'\0' => sub { sprintf '\x{%0.4x}', oct $_ },
);

sub transchars {
	my ($pat) = @_;

	# Positive blocky escapes...
	for my $esc (qw(\c \x \0)) {
		my $esclen = length($esc)+1;
		while (1) {
			my $from = index($pat, $esc.'[');
			last unless $from >= 0;
			my $to = index(substr($pat,$from+$esclen),']');
			error("Empty $esc\[...]") and last if $to == 0;
			substr($pat,$from,$to+$esclen+1) =
				join "", map { $trans{$esc}() }
						 map { split ';', $_  }
						 map { split '; ', $_ }
							substr($pat,$from+$esclen,$to);
		}
	}

	# Negative blocky escapes...
	for my $esc (qw(\C \X)) {
		my $esclen = length($esc)+1;
		while (1) {
			my $from = index($pat, $esc.'[');
			last unless $from >= 0;
			my $to = index(substr($pat,$from+$esclen),']');
			error("Empty $esc\[...]") and last if $to == 0;
			my @chars =  map { split ';', $_  }
						 map { split '; ', $_ }
							substr($pat,$from+$esclen,$to);
			my $after = @chars > 1
							? join("",map $trans{lc $esc}(), @chars[1..$#chars])
							: "";
			substr($pat,$from,$to+$esclen+1) =
				"(?:" . do{local $_=$chars[0]; $trans{$esc}()} . $after . ")";
		}
	}
	return $pat;
}

my ($cs_excl, $cs_incl) = (0,1);

sub transcharset {
	my ($pat, $sign) = @_;
	my $neg = $sign eq '-' ? 1 : 0;

	my @result = ([],[]);

	for my $esc ($neg ? qw(\C \X) : qw(\c \x \0)) {
		my $esclen = length($esc)+1;
		while (1) {
			my $from = index($pat, $esc.'[');
			last unless $from >= 0;
			my $to = index(substr($pat,$from+$esclen),']');
			error("Empty $esc\[...]") and last if $to == 0;
			push @{$result[$cs_incl]},
				join "", map { $trans{lc $esc}() }
				 		 map { split ';', $_  }
				 		 map { split '; ', $_ }
							 substr($pat,$from+$esclen,$to);
			substr($pat,$from,$to+$esclen+1) = "";
		}
	}

	for my $esc ($neg ? qw(\c \x \0) : qw(\C \X)) {
		my $esclen = length($esc)+1;
		while (1) {
			my $from = index($pat, $esc.'[');
			last unless $from >= 0;
			my $to = index(substr($pat,$from+$esclen),']');
			error("Empty $esc\[...]") and last if $to == 0;
			push @{$result[$cs_excl]},
				join "", map { $trans{lc $esc}() }
				 		 map { split ';', $_  }
				 		 map { split '; ', $_ }
							 substr($pat,$from+$esclen,$to);
			substr($pat,$from,$to+$esclen+1) = "";
		}
	}

	unshift @{$result[$neg ? $cs_excl : $cs_incl]}, $pat unless $pat eq '[]';
	return \@result;
}


# Handle declaration of (...) captures

sub capture_external {
    return unless @mark;    # Implies unbalanced closing paren
    $raw .= ')';
    my $mark = pop @mark;
    my $index = $capindex[-1];
    my $sigil = substr($index,0,1);
    pop @capindex unless $sigil eq '@' || $sigil eq '%';
    my $action;
    if ($sigil eq '$') {
        $action = "\$Perl6::Rules::exvar{scalar}{q{$index}}||=\\$index;"
                . "local $index = \$^N";
    }
    elsif ($sigil eq '@') {
        $action = "\$Perl6::Rules::exvar{array}{q{$index}}||=\\$index;"
                . "local $index=$index; Perl6::Rules::apparray(\\$index, \$^N)";
    }
    elsif ($sigil eq '%') {
        $action = "\$Perl6::Rules::exvar{hash}{q{$index}}||=\\$index;"
                . "local $index=$index; Perl6::Rules::apphash(\\$index, \$^N)";
    }
    else {
        $action = "local \$Perl6::Rules::d0[$index] = \$^N";
    }
    splice @p5pat, $mark, @p5pat-$mark, "(@p5pat[$mark..$#p5pat])(?{$action})";
}

my %nametype = (
    '@' => 'array',
    '%' => 'hash',
    '$' => 'scalar',
);

sub caparraymark_external {
    my ($name) = @_;
    debug "Setting $name as capture target";
    $raw .= "$name := [";
    push @capindex, $name;
    push @mark, scalar @p5pat;
    my $sigil = substr($name,0,1);
    my $save = "\$Perl6::Rules::exvar{$nametype{$sigil}}{q{$name}}||=\\$name";
    push @p5pat, "(?{$save;local $name = ($name,undef)})";
}

sub caparraymark_internal {
    my ($name) = @_;
    debug "Setting $name as capture target";
    $raw .= "$name := [";
    push @capindex, $name;
    push @mark, scalar @p5pat;
    my $storage = "\$Perl6::Rules::d0{q{$name}}";
    push @p5pat, "(?{local $storage = [\@{$storage},undef]})";
}

sub endcaparraymark {
    return unless @mark;    # Implies unbalanced closing paren
    $raw .= ']';
    my $mark = pop @mark;
    my $name = pop @capindex;
    splice @p5pat, $mark, @p5pat-$mark, "(?:@p5pat[$mark..$#p5pat])";
}

sub caphashmark_external {
    my ($name) = @_;
    debug "Setting $name as capture target";
    $raw .= "$name := [";
    push @capindex, $name;
    push @mark, scalar @p5pat;
    my $sigil = substr($name,0,1);
    my $save = "\$Perl6::Rules::exvar{$nametype{$sigil}}{q{$name}}||=\\$name";
    push @p5pat, "(?{$save;local $name = ($name, ''=>undef)})";
}

sub caphashmark_internal {
    my ($name) = @_;
    debug "Setting $name as capture target";
    $raw .= "$name := [";
    push @capindex, $name;
    push @mark, scalar @p5pat;
    my $storage = "\$Perl6::Rules::d0{q{$name}}";
    push @p5pat, "(?{local $storage = {\%{$storage}, ''=>undef}})";
}

sub endcaphashmark {
    return unless @mark;    # Implies unbalanced closing paren
    $raw .= ']';
    my $mark = pop @mark;
    my $name = pop @capindex;
    splice @p5pat, $mark, @p5pat-$mark, "(?:@p5pat[$mark..$#p5pat])";
}

sub noncapture {
    return unless @mark;    # Implies unbalanced closing square bracket
    $raw .= ']';
    debug "Closing non-capturing block\n";
    my $mark = pop @mark;
    splice @p5pat, $mark, @p5pat-$mark, "(?:@p5pat[$mark..$#p5pat])";
    add_debug $p5pat[-1], "non-capturing block";
}

sub rulename {
    $rulename = $^N;
}

sub empty {
    error "Empty pattern not allowed (use // or //)";
}

sub badrep {
    error "Invalid quantifier: /$raw$^N <--HERE .../";
    $raw .= $^N;
}

sub invalid {
    error "Invalid Perl 6 pattern (perhaps mismatched brackets?): $_[0]";
}

# Parser starts here...

our $comment  = q{[#][^\n]*};           # Comment

our $ws    = qr{(?:$comment|\s)+};      # WhiteSpace
our $ows   = qr{(?:$comment|\s)*};      # Optional WhiteSpace
our $ident = qr{(?>[^\W\d]\w*)};        # Identifier
our $int   = qr{(?:\d+|\$$ident)};      # Integer for range
our $rrep  = qr{<$int(?:,$int?)?>};     # Range repeater

our $qualident = qr{(?> $ident? (?: :: $ident)+ )}x;     # Qualified identifier
our $callident = qr{(?> $ident (::$ident)* (?:\.$ident)? )}x;
                                                        # Qualified Perl6 call

our $rep   = qq{((?:[*+?]|$rrep)[?]?)};
our $orep  = qq{((?:[*+?]|$rrep)?[?]?)};
our $stdrep  = qq{$orep (?{repeat})};   # Optional repeater

our $sliteral = q{[-\w~`!=;"',]};       # Literal for a Slash-delimited pattern
our $bliteral = q{[-\w~`!=;"',/]};      # Literal for a Bracketed pattern

our $bracket = q{\[|\]|\{|\}|\<|\>|\(|\)};     # Any bracket

our $squareblock = qr{ \[ (?: (?> (?:[^][]|\\.)+ ) | (??{$squareblock}) )* \] }x;
our $braceblock  = qr{ \{ (?: (?> (?:[^{}]|\\.)+ ) | (??{$braceblock}) )* \} }x;
our $parenblock  = qr{ \( (?: (?> (?:[^()]|\\.)+ ) | (??{$parenblock}) )* \) }x;
our $angleblock  = qr{ \< (?: (?> (?:[^<>]|\\.)+ ) | (??{$angleblock}) )* \> }x;
our $slashblock  = qr{        (?> (?:[^/]|\\.)*  ) / }x;

our $delimblock  = qr{ $braceblock
                 | $squareblock
                 | $parenblock
                 | $angleblock
                 }x;

our $charset = qr{ \[ \]? (?:\\[cCxX]\[ [^]]* \]|\\.|[^]])* \] }xs;

our $mods = qr{ (?> (?: : \w+ (?: $parenblock? ) )* ) }x;

# These would be preferrable, but are not reliable...
# 	our $newline    = qr{(?:\015\012?|[\012\x85\x2028])};
#	our $notnewline = qr{(?:(?!\015\012?|[\012\x85\x2028])[\s\S])};
# So we cheat with these instead...

our $newline    = qr{\n};
our $notnewline = qr{[^\n]};

our %ews = (                # Explicit WhiteSpace
    q{\h}   => q{[ \t\r]},
    q{\v}   => $newline,
    q{\s}   => q{(?:\015\012?|[\s\012\x85\x2028])},
    q{} => q{(?:\s+)},
    q{} => q{[ ]},
);

our $ews = '(?:' . join('|',map quotemeta, keys %ews) . ')';

# Internal scalars...
our $i_scalar   = qr{ (?: \$ \? $ident
                        | \@ \? $ident $squareblock
                        | \% \? $ident $braceblock
                      )
                      (?: \.? (?>$squareblock|$braceblock) )*
                    }x;
our $i_array    = qr{ \@ \? $ident }x;
our $i_hash     = qr{ \% \? $ident }x;

# External scalars...
our $e_scalar   = qr{ (?: \$ $qualident
                        | \@ $qualident $squareblock
                        | \% $qualident $braceblock
                      )
                    (?: (?:\.)? (?>$squareblock|$braceblock) )*
                  }x;
our $e_array    = qr{ \@ $qualident }x;
our $e_hash     = qr{ \% $qualident }x;

# Unqualified externals not allowed...

our $bad_var    = qr{ [\$\@%] $ident (?! :) }x;

our $codeblock = qr{
    (?{$debug = 2 if $debug})
    (\{) (?{mark($^N)})
    (?>
        (?: ($i_scalar) (?{addscalar_internal $^N, 'rw'})
          | ($e_scalar) (?{addscalar_external $^N, 'rw'})
          | ($i_array)  (?{addarray_internal $^N, 'rw'})
          | ($e_array)  (?{addarray_external $^N, 'rw'})
          | ($i_hash)   (?{addhash_internal $^N, 'rw'})
          | ($e_hash)   (?{addhash_external $^N, 'rw'})
          | \$ (\d+)    (?{add '$'.$^N, "\$Perl6::Rules::d0[$^N]"})
          | ((?:\$\^\w+|[^{}\$]|\\[{}\$])+) (?{add $^N, $^N})
          | (??{$nestedcodeblock})
        )*
    )
    (?{$debug = 1 if $debug})
    (\}) (?{codeblock($^N)})
    |
    (??{$debug=1 if $debug;'(?!)'})
}x;

our $nestedcodeblock = qr{
    (\{) (?{mark($^N)})
    (?>
        (?: ($i_scalar) (?{addscalar_internal $^N, 'rw'})
          | ($e_scalar) (?{addscalar_external $^N, 'rw'})
          | ($i_array)  (?{addarray_internal $^N, 'rw'})
          | ($e_array)  (?{addarray_external $^N, 'rw'})
          | ($i_hash)   (?{addhash_internal $^N, 'rw'})
          | ($e_hash)   (?{addhash_external $^N, 'rw'})
          | ($bad_var)  (?{error("Can't use unqualified variable ($^N)")})
          | \$ (\d+)    (?{add '$'.$^N, "\$Perl6::Rules::d0[$^N]"})
          | ((?:\$\^\w+|[^{}\$]|\\[{}\$])+) (?{add $^N, $^N})
          | (??{$nestedcodeblock})
        )*
    )
    (\}) (?{codeblock($^N,'nested')})
}x;

our $assertblock = qr[
    (?{$debug=2 if $debug})
    (<\() (?{mark($^N)})
    (?>
        (?: ($i_scalar) (?{addscalar_internal $^N, 'rw'})
          | ($e_scalar) (?{addscalar_external $^N, 'rw'})
          | ($i_array)  (?{addarray_internal $^N, 'rw'})
          | ($e_array)  (?{addarray_external $^N, 'rw'})
          | ($i_hash)   (?{addhash_internal $^N, 'rw'})
          | ($e_hash)   (?{addhash_external $^N, 'rw'})
          | ($bad_var)  (?{error("Can't use unqualified variable ($^N)")})
          | \$ (\d+)    (?{add '$'.$^N, "\$Perl6::Rules::d0[$^N]"})
          | ((?:\$\^\w+|[^{\)\$]|\\[{\)\$])+) (?{add $^N, $^N})
          | (??{$nestedcodeblock})
        )*
    )
    (?{$debug=1 if $debug})
    (\)>) (?{codeblock($^N)})
    |
    (??{$debug=1 if $debug;'(?!)'})

]x;


our $bspat = qr{                # Bracketed and Slashed patterns

 # Explicit whitespace (possibly repeated)...

      $ows ($ews)
            (?{add $^N, $ews{$^N}})
      $stdrep $ows

 # Actual whitespace (insert :words spacing if in appropriate mode)...

    | $ws
            (?{wordspace})

 # Backreference as literal (interpolated $1, $2, etc.)...

    | \$ (\d+)
            (?{add '$'.$^N, "(??{quotemeta \$Perl6::Rules::d0[$^N]})"})
      $stdrep

 # Interpolated variable as literal...

    | ($i_scalar) (?{ addscalar_internal $^N, 'quotemeta' }) $stdrep
    | ($i_array)  (?{ addarray_internal $^N, 'quotemeta' })  $stdrep
    | ($i_hash)   (?{ addhash_internal $^N, 'quotemeta' })   $stdrep
    | ($e_scalar) (?{ addscalar_external $^N, 'quotemeta' }) $stdrep
    | ($e_array)  (?{ addarray_external $^N, 'quotemeta' })  $stdrep
    | ($e_hash)   (?{ addhash_external $^N, 'quotemeta' })   $stdrep
    | ($bad_var)  (?{error("Can't use unqualified variable ($^N)")})

 # Character class...

    | < (?: ([+-]?) (?{$^N||""}) ($charset)
            (?{mark ""; add "<$^R.$^N", transcharset($^N, $^R)})
		|   ([+-]?) (?{$^N||""}) < ([-!]? $ident) >
            (?{mark ""; add "<$^R.$^N", getprop($^N, $^R)})
		)
        (?: ([+-]?) (?{$^N||""}) ($charset)
            (?{add "$^R.$^N", transcharset($^N, $^R)})
		|   ([+-]?) (?{$^N||""}) < ([-!]? $ident) >
            (?{add "$^R.$^N", getprop($^N, $^R)})
		)*
      >
            (?{make_charset})
      $stdrep

 # <(...)> assertion block...

    | $assertblock

 # Backreference as pattern (interpolated <$1>, <$2>, etc.)...

    | <(\$ \d+)>
            (?{add "<$^N>", error("Cannot interpolate $^N as pattern")})

 # Interpolate variable as pattern...

    | <($i_scalar)> (?{addscalar_internal $^N}) $stdrep
    | <($i_array)>  (?{addarray_internal $^N})  $stdrep
    | <($i_hash)>   (?{addhash_internal $^N})   $stdrep
    | <($e_scalar)> (?{addscalar_external $^N}) $stdrep
    | <($e_array)>  (?{addarray_external $^N})  $stdrep
    | <($e_hash)>   (?{addhash_external $^N})   $stdrep
    | <($bad_var)>  (?{error("Can't use unqualified variable (<$^N>)")})

 # Code block as action...

    | $codeblock

 # Code block as interpolated pattern...

    | <($braceblock)>
            (?{add $^N, "(??{Perl6::Rules::ispat do$^N})"})

 # Literal in <'...'> format...

    | <' ( [^'\\]* (\\. [^'\\])* ) '>
            (?{add "<'$^N'>", "\Q$^N\E"})

 # Match any Unicode character, regardless of :uN level...

    | (< \. >)
            (?{add $^N, '(?:\X)'})

 # Match newline or anything-but-newline...

    | \\n
            (?{add '\n', $newline}) $stdrep
    | \\N
            (?{add '\N', $notnewline}) $stdrep

 # Quotemeta's literal (\Q[...])...

    | \\Q ( $squareblock )
            (?{add "\\Q$^N", quotemeta substr($^N,1,-1)}) $stdrep

 # Named and numbered characters (\c[...], \C[...], \x[...], \0[...], etc)...

    | ( \\[cCxX0] $squareblock
      | \\[xX][0-9A-Fa-f]+
      | \\0[0-7]+
      )
            (?{add $^N,  transchars($^N)}) $stdrep

	| (\\[cCxX0] \[) (?{$^N}) ((?>.*))
			(?{error "Untermimated $^R...] escape: $^R$^N"})

 # Literal dot...

    | (\\.)
            (?{add $^N, $^N}) $stdrep

 # Backtracking limiter...

    | : (?=\s|\z)
            (?{nobacktrack})

 # Lexical insensitivity...

    | :i
            (?{add ":i", '(?i)'})

 # Continuation marker...

    | :c (?{add '\G'})

 # Other lexical flags (NOT YET IMPLEMENTED)...

    | :(u0|u1|u2|u3|w|p5)
            (?{error "In-pattern :$^N not yet implemented"})

 # Match any character...

    | \.
            (?{add '.', '[\s\S]'}) $stdrep

 # Start of line marker...

    | \^\^
            (?{add '^^', '(?:(?<=\n)|(?<=\A))'})

 # End of line marker...

    | \$\$
            (?{add '$$', '(?:(?<=\n)|(?=\z))'})

 # Start of string marker...

    | \^
            (?{add '^', '\A'})

 # End of string marker...

    | \$
            (?{add '$', '\z'})

 # Non-capturing subrule or property...

    | < ($callident) >
            (?{subrule($^N,"")}) $stdrep

    | < - ($callident) >
            (?{subrule($^N,"","","-")}) $stdrep

    | < ! ($callident) >
            (?{subrule($^N,"","","!")}) $stdrep

 # Capturing subrule...

    | < \? ($callident) >
            (?{$Perl6::Rules::srname=$^N})
      $ows $rep
            (?{ subrule($Perl6::Rules::srname, $^N, "cap")})
    | < \? ($callident) >
            (?{ subrule($^N, "", "cap")})

 # Alternative marker...

    | \|
            (?{alternative})

 # Comment...

    | $comment

 # Unattached repetition marker...

    | ($orep)
            (?{$^N&&badrep()})

}x;


our $spat   = qr{               # Slash-delimited pattern

 # A literal character...

    (?: ($sliteral)
            (?{add $^N, $^N}) $stdrep

 # Lookahead and lookbehind...

    |   (
            (?{mark $^N})
        (??{$spat}) >
            (?{lookaround('(?=')})

    |   (
            (?{mark $^N})
        (??{$spat}) >
            (?{lookaround('(?!')})

    |   (
            (?{mark $^N})
        (??{$spat}) >
            (?{lookaround('(?<=')})

    |   (
            (?{mark $^N})
        (??{$spat}) >
            (?{lookaround('(?

 # Named capture...

    |   \$ (\d+) $ows := $ows \(
            (?{setcapindex $^N; capmark})
        (??{$spat}) \)
            (?{capture_internal $^R})

    |   ($i_scalar) $ows := $ows \(
            (?{capmark $^N})
        (??{$spat}) \)
            (?{capture_internal $^R})

    |   ($e_scalar) $ows := $ows \(
            (?{capmark $^N})
        (??{$spat}) \)
            (?{capture_external $^R})

    |   ($i_array) $ows := $ows \(
            (?{caparraymark_internal $^N; capmark;})
        (??{$spat}) \)
            (?{capture_internal; endcaparraymark;})
        $stdrep

    |   ($e_array) $ows := $ows \(
            (?{caparraymark_external $^N; capmark;})
        (??{$spat}) \)
            (?{capture_external; endcaparraymark;})
        $stdrep

    |   ($i_array) $ows := $ows \[
            (?{caparraymark_internal $^N})
        (??{$spat}) \]
            (?{endcaparraymark})
        $stdrep

    |   ($e_array) $ows := $ows \[
            (?{caparraymark_external $^N})
        (??{$spat}) \]
            (?{endcaparraymark})
        $stdrep

    |   ($i_hash) $ows := $ows \(
            (?{caphashmark_internal $^N; capmark;})
        (??{$spat}) \)
            (?{capture_internal; endcaphashmark;})
        $stdrep

    |   ($e_hash) $ows := $ows \(
            (?{caphashmark_external $^N; capmark;})
        (??{$spat}) \)
            (?{capture_external; endcaphashmark;})
        $stdrep

    |   ($i_hash) $ows := $ows \[
            (?{caphashmark_internal $^N})
        (??{$spat}) \]
            (?{endcaphashmark})
        $stdrep

    |   ($e_hash) $ows := $ows \[
            (?{caphashmark_external $^N})
        (??{$spat}) \]
            (?{endcaphashmark})
        $stdrep

 # Other non-delimiter-specific constructs (as defined by $bspat above)...

    |   $bspat

 # Nameless capture...

    |   \(
            (?{capmark})
        (??{$spat}) \)
            (?{capture_internal})
        $stdrep

 # Non-capturing group...

    |   \[
            (?{mark '['})
        (??{$spat}) \]
            (?{noncapture})
        $stdrep
    )+
}x;

our $bpat   = qr{               # Bracketed pattern
    (?:

 # A literal character...

        ($bliteral) (?{add $^N, $^N}) $stdrep

 # Lookahead and lookbehind...

    |   (
            (?{mark $^N})
        (??{$bpat}) >
            (?{lookaround('(?=')})

    |   (
            (?{mark $^N})
        (??{$bpat}) >
            (?{lookaround('(?!')})

    |   (
            (?{mark $^N})
        (??{$bpat}) >
            (?{lookaround('(?<=')})

    |   (
            (?{mark $^N})
        (??{$bpat}) >
            (?{lookaround('(?

 # Named capture...

    |   \$ (\d+) $ows := $ows \(
            (?{setcapindex $^N; capmark})
        (??{$bpat}) \)
            (?{capture_internal $^R})

    |   ($i_scalar) $ows := $ows \(
            (?{capmark $^N})
        (??{$bpat}) \)
            (?{capture_internal $^R})

    |   ($e_scalar) $ows := $ows \(
            (?{capmark $^N})
        (??{$bpat}) \)
            (?{capture_external $^R})

    |   ($i_array) $ows := $ows \(
            (?{caparraymark_internal $^N; capmark;})
        (??{$bpat}) \)
            (?{capture_internal; endcaparraymark;})
        $stdrep

    |   ($e_array) $ows := $ows \(
            (?{caparraymark_external $^N; capmark;})
        (??{$bpat}) \)
            (?{capture_external; endcaparraymark;})
        $stdrep

    |   ($i_array) $ows := $ows \[
            (?{caparraymark_internal $^N})
        (??{$bpat}) \]
            (?{endcaparraymark})
        $stdrep

    |   ($e_array) $ows := $ows \[
            (?{caparraymark_external $^N})
        (??{$bpat}) \]
            (?{endcaparraymark})
        $stdrep

 # Other non-delimiter-specific constructs (as defined by $bspat above)...

    |   $bspat

 # Nameless capture...

    |   \(
            (?{capmark})
        (??{$bpat}) \)
            (?{capture_internal})
        $stdrep

 # Non-capturing group...

    |   \[
            (?{mark '['})
        (??{$bpat}) \]
            (?{noncapture})
        $stdrep
    )+
}x;

our $rx = qr{

# Nameless rule requires {...} delimiters...

      \b rule $ows ($mods) (?{mods}) $ows
      (?> (\{) (?{delim}) (?: $ows \} (?{empty})|$bpat \} )
        | ( (?:\{|\[|\<|/) .*) (?{invalid('rx'.$^N)})
      )

# Nameless rx allows /.../ or any bracket delimiters...

    | \b rx   $ows ($mods) (?{mods}) $ows
      (?> (\{) (?{delim}) (?: $ows \} (?{empty})|$bpat \} )
        | (\[) (?{delim}) (?: $ows \] (?{empty})|$bpat \] )
        | (\<) (?{delim}) (?: $ows \> (?{empty})|$bpat \> )
        | (/)  (?{delim}) (?: $ows /  (?{empty})|$spat /  )
        | ( (?:\{|\[|\<|/) .*) (?{invalid('rx'.$^N)})
      )
}x;


our $match = qr{

# Match construct allows /.../ or any bracket delimiters...

      \b m \b $ows ($mods) (?{mods}) $ows
      (?> (\{) (?{delim}) (?: $ows \} (?{empty})|$bpat \} )
        | (\[) (?{delim}) (?: $ows \] (?{empty})|$bpat \] )
        | (\<) (?{delim}) (?: $ows \> (?{empty})|$bpat \> )
        | (/)  (?{delim}) (?: $ows /  (?{empty})|$spat /  )
        | ( (?:\{|\[|\<|/) .*) (?{invalid('m'.$^N)})
      )
}x;

our $subst = qr{

# Substitution construct allows /.../ or any bracket delimiters...

 \b s $ows ($mods) (?{mods}) $ows
 (?> (\{) (?{delim}) (?: $ows \} (?{empty})|$bpat \} ) ($delimblock)
   | (\[) (?{delim}) (?: $ows \] (?{empty})|$bpat \] ) ($delimblock)
   | (\<) (?{delim}) (?: $ows \> (?{empty})|$bpat \> ) ($delimblock)
   | (/)  (?{delim}) (?: $ows /  (?{empty})|$spat /  ) ($slashblock|$delimblock)
   | ( (?:\{|\[|\<|/) .*) (?{invalid('s'.$^N)})
 )
}x;


# Unimplemented modifiers...

my %unimpl;
@unimpl{qw(u0 u1 u2 u3 once p5 perl5)} = ();

# Limit interpolated rules to precompiled regexes
# (at least, until recursive rule translation can be made to work)...

sub ispat {
    my ($pat) = @_;
    warn qq{Cannot interpolate raw string "$pat" as pattern\n} and exit(1)
        unless (ref($pat)||"") eq 'Regexp';
    return $pat;
}

sub arepat {
    ispat($_) for @_;
}


# Extract and translate rule modifiers

sub mods {
    my @mods = split ":", $^N;
    while (defined(my $mod = shift @mods)) {
        if ($mod eq 'words' || $mod eq 'w') {
            debug "Found skip-whitespace modifier (:$mod)\n";
            $mod{words} = 1;
        }
        elsif ($mod eq 'globally' || $mod eq 'g') {
            debug "Found match-all modifier (:$mod)\n";
            $mod{post}{g} = 1;
        }
        elsif ($mod eq 'exhaustive' || $mod eq 'e') {
            debug "Found match-every-way modifier (:$mod)\n";
            $mod{exhaust} = 1;
			error "Can't specify both :exhaustive and :overlap on the same rule"
				if $mod{overlap};
        }
        elsif ($mod eq 'overlap' || $mod eq 'o') {
            debug "Found match-overlapping modifier (:$mod)\n";
            $mod{overlap} = 1;
			error "Can't specify both :exhaustive and :overlap on the same rule"
				if $mod{exhaust};
        }
        elsif ($mod eq 'ignore' || $mod eq 'i') {
            debug "Found ignore-case modifier (:$mod)\n";
            $mod{post}{i} = 1;
        }
        elsif ($mod eq 'cont' || $mod eq 'c') {
            debug "Found match continuation modifier (:$mod)\n";
            $mod{pre}{'\G'} = 1;
            $mod{post}{gc}  = 1;
        }
        elsif (length $mod > 5 && substr($mod,0,4) eq 'nth(' && substr($mod,-1) eq ')') {
            $mod{nth} = substr($mod,4,-1);
            debug "Found $mod{nth}th repetition modifier (:$mod)\n";
        }
        elsif ( length $mod > 2 && substr($mod,0,1) ne 'n' &&
			    (substr($mod,-2) eq 'th' || substr($mod,-2) eq 'st'
			    || substr($mod,-2) eq 'nd' || substr($mod,-2) eq 'rd')
			  ) {
            $mod{nth} = substr($mod,0,-2);
            debug "Found $mod{nth}th repetition modifier (:$mod)\n";
        }
        elsif (length $mod > 3 && substr($mod,0,2) eq 'x(' && substr($mod,-1) eq ')' ) {
            $mod{rep} = substr($mod,2,-1);
            debug "Found $mod{rep}-times repetition modifier (:$mod)\n";
        }
        elsif (length $mod > 1 && substr($mod,-1) eq 'x' ) {
            $mod{rep} = substr($mod,0,-1);
            debug "Found $mod{rep}-times repetition modifier (:$mod)\n";
        }
        elsif (substr($mod,0,3) eq "nth" or substr($mod,0,1) eq "x") {
            error "Missing parens after :$mod modifier";
        }
        elsif (exists $unimpl{$mod}) {
            error "The :$mod modifier is not currently implemented";
        }
        elsif (length($mod) > 1) {
            debug "Unknown modifier (:$mod). Trying to split.\n";
            unshift @mods, substr($mod,-1,1,"") while length $mod;
        }
        elsif (length $mod) {
            error "Unknown modifier (:$mod)"
        }
    }
}

# STD RULES AND PROPERTIES

my %stdrules = (
     alpha => qr{[^\W\d_]},
    -alpha => qr{[\W\d_]},
     space => qr{\s},
    -space => qr{\S},
     digit => qr{\d},
    -digit => qr{\D},
	 alnum => qr{[^\W_]},
	-alnum => qr{[\W_]},
	 ascii => qr{\p{InBasicLatin}},
	-ascii => qr{\P{InBasicLatin}},
	 blank => qr{[ \t\r]},
	-blank => qr{[^ \t\r]},
	 cntrl => qr{[[:cntrl:]]},
	-cntrl => qr{[^[:cntrl:]]},
	  ctrl => qr{[[:cntrl:]]},
	 -ctrl => qr{[^[:cntrl:]]},
	 graph => qr{[[:graph:]]},
	-graph => qr{[^[:graph:]]},
	 lower => qr{\p{Ll}},
	-lower => qr{\P{Ll}},
	 print => qr{[[:print:]]},
	-print => qr{[^[:print:]]},
	 punct => qr{\p{P}},
	-punct => qr{\P{P}},
	 upper => qr{\p{Lu}},
	-upper => qr{\P{Lu}},
	 word  => qr{\w},
	-word  => qr{\W},
	xdigit => qr{\p{HexDigit}},
   -xdigit => qr{\P{HexDigit}},

     ident => qr{[^\W\d]\w*},
      null => qr{(?=)},
);

# Locate back-translation for a std rule (like )...

sub stdrule {
    my ($name, $invert) = @_;
	my $iname = $invert ? -$name : $name;
    my $stdrule = $stdrules{$iname};
	if (defined $stdrule) {
		debug "Matching <$iname> with subrule /$stdrule/\n";
		return qr{($stdrule) (?{$0=$^N})}x;
	}
	elsif (index($name,'.') >= 0) {
		die "Cannot match unknown named rule: <$iname>\n";
	}
	elsif ($invert) {
		$name = 'L&' if $name eq 'Lr';
		debug "Matching <$iname> with property \\P{$name}\n";
		return qr{\P{$name}};
	}
	else {
		$name = 'L&' if $name eq 'Lr';
 		debug "Matching <$iname> with property \\p{$name}\n";
		return qr{\p{$name}};
	}
}

# Locate back-translation for a std properties in a charset
# such as: <+>...

my %stdprop = (
    alpha => '[^\W\d_]',
    digit => '\d',
	space => '\s',
	alnum => '[^\W_]',
	ascii => '\p{InBasicLatin}',
	blank => '[ \t\r]',
	cntrl => '[[:cntrl:]]',
	 ctrl => '[[:cntrl:]]',
	graph => '[[:graph:]]',
	lower => '\p{Ll}',
	print => '[[:print:]]',
	punct => '\p{P}',
	upper => '\p{Lu}',
	word  => '\w',
	xdigit => '\p{HexDigit}',
);

sub getprop {
	my ($name, $sign) = @_;
	my $neg = $sign eq '-' ? 1 : 0;
	my $insign = substr($name,0,1);
	my @result = ([],[]);

	if ($insign eq '-') {
		substr($name,0,1) = "";
		$neg = 1-$neg;
	}
	elsif ($insign eq '!') {
		substr($name,0,1) = "";
		error "Can't use negative lookahead  inside character class. "
		    . "Did you mean <-$name>?";
		return \@result;
	}

	$name = 'L&' if $name eq 'Lr';
	$result[$neg ? $cs_excl : $cs_incl][0] = $stdprop{$name} || "\\p{$name}";
	return \@result;
}


# Filter source to translate rules...

use Filter::Simple; our @CARP_NOT = 'Filter::Simple';
FILTER {
    return unless $_;
    $debug = 1 if grep /-debug\b/, @_;
    $translate = 1 if grep /-translate\b/, @_;
    $bad = 0;

    # Convert Perl6ish traits to Perl5ish attributes...

    s[ is $ws (keymatch|valuematch) $ows \( $ows (?:rx|rule) $ows ]
     [ :\u$1(]gx;

    # Convert Perl6ish grammars to Perl5ish packages

    s[grammar $ws ($qualident|$ident) (?: $ws is $ws ($qualident|$ident))? $ows \{ ]
     [ $2 ? "{ package $1; use base '$2'; no warnings 'regexp';"
          : "{ package $1; no warnings 'regexp';"
     ]gex;

    # Convert Perl6ish named rules to Perl5ish named subroutines...

    s[(?{new}) \b rule $ws ($ident) (?{rulename})
                       $ows ($mods?) (?{mods})
               $ows (\{) (?{delim}) $bpat \}
     ]
     [to_rule()]gex;

    # Convert Perl6ish unnamed rules and rx's to Perl5ish qr's...

    s[(?{new})($rx)]
     [to_qms('qr')]gex;

    # Convert Perl6ish matches to Perl5ish matches...

    s[(?{new})$match]
     [to_qms('m')]gex;

    # Convert Perl6ish substitutions to Perl5ish substitutions...

    s[(?{new})$subst]
     [to_qms('s',undef,$^N)]gex;

    # Convert references to $1, $2, $3, etc. to $0->[1], $0->[2], $0->[3], etc.

    our $curlies = qr/\{ (?: (?> [^}{]+) | (??{$curlies}))* \}/x;
    our $parens  = qr/\( (?: (?> [^)(]+) | (??{$parens }))* \)/x;
    our $squares = qr/\[ (?: (?> [^][]+) | (??{$squares}))* \]/x;
    our $angles  = qr/\< (?: (?> [^><]+) | (??{$angles }))* \>/x;

    my $non_interp_str = qr{
                         ' [^'\\]* (?: \\. [^'\\]* )*  '
      | q (?: [wxr]? \s* ' [^'\\]* (?: \\. [^'\\]* )*  '
            | w?     \s* / [^/\\]* (?: \\. [^/\\]* )*  /
            | w?     \s* ! [^!\\]* (?: \\. [^!\\]* )*  !
            | w?     \s* \# [^#\\]* (?: \\. [^#\\]* )* \#
            | w?     \s* \| [^|\\]* (?: \\. [^|\\]* )* \|
            | w?     \s* (?: $curlies | $parens | $squares | $angles)
          )
    }xs;

    s/ ( $non_interp_str )
     | (?[$2]"/gesx;

    # Fail if any errors were detected in any of that...

    if ($bad) {
        warn "Fatal error", ($bad>1?"s":""), " in one or more Perl 6 rules\n";
        exit($bad);
    }

    # Turn of regex warnings in the resulting filtered code
    # ('cos we did some wicked evil things in those back-translated regexes)...

    $_ = "no warnings 'regexp';use re 'eval';$_";

    # Show the resulting source if we're translating

    if ($translate) {
        warn "Source translated to:\n__START__\n" if $debug;
        print;
        print "\n__END__\n" if $debug;
        exit unless $debug;
    }
};

# Implement the C and C traits on hashes...

use Attribute::Handlers;

sub UNIVERSAL::Keymatch :ATTR(HASH,RAWDATA) {
    my ($package, $symbol, $referent, $attr, $data) = @_;

    # Prepend the anonymous pattern marker, if necessary...
    $data =~ s/^\s*(?!rx)/rx/;

    # Back-translate the resulting pattern...
    $data =~ s[(?{new})($rx)][to_qms('qr')]gex
        or croak 'Usage: %var : Keymatch(/pattern/)';

    # Cache the result...
    $keymatch{$referent} = $data;
}

sub UNIVERSAL::Valuematch :ATTR(HASH,RAWDATA) {
    my ($package, $symbol, $referent, $attr, $data) = @_;

    # Prepend the anonymous pattern marker, if necessary...
    $data =~ s/^\s*(?!rx)/rx/;

    # Back-translate the resulting pattern...
    $data =~ s[(?{new})($rx)][to_qms('qr')]gex
        or croak 'Usage: %var : Valuematch(/pattern/)';

    # Cache the result...
    $valuematch{$referent} = $data;
}

# Build a named Perl5ish subroutine/method that
# implements a named Perl6ish rule...

sub to_rule {
    local $" = "";
    my $trans = "sub $rulename { ". to_qms('qr',$rulename) . " }";
    return $trans;
}

# Wrap the back-translated elements of a Perl6ish pattern
# in the necessary Perl5ish regex magic...

sub to_qms {
    my ($type,$name,$repl) = @_;
    local $" = "";

    # /gc flag not possible on Perl5ish qr's...

    delete $mod{post}{gc} if $type eq "qr";

    # Default to a temporary name, if Perl6ish pattern is unnamed...

    $name ||= "anon_$type";



    # Prepare "decorations" for the back-translation...

    my $priorness = $has_prior ? "" : "\$Perl6::Rules::prior = $rule_id;";

	my $repcontrol =
		exists $mod{nth} && ($mod{post}{g} || $mod{post}{gc}) ?
				q[)(??{++$Perl6::Rules::count%].$mod{nth}.q[==0?'':'(?!)'})]
	  : exists $mod{nth} ?
				q[)(??{++$Perl6::Rules::count==].$mod{nth}.q[?'':'(?!)'})]
	  : exists $mod{rep} && $type eq 'm' ?
			(exists $mod{post}{gc}
				?  q[){].$mod{rep}.q[}]
				:  q[(?s:.*?)){].$mod{rep}.q[}]
			)
	  : exists $mod{rep} && $type eq 's' ?
				q[)(??{++$Perl6::Rules::count<=].$mod{rep}.q[?'':'(?!)'})]
	  :         q{};

	if (exists $mod{rep} && ($mod{post}{g} || $mod{post}{gc})) {
		error "Can't specify both :globally and :x($mod{rep}) on the same rule";
	}
	$mod{post}{g} = 1 if $repcontrol && $type eq 's' && !$mod{post}{gc};

	my $repprecontrol = !$repcontrol                     ? ''
					  : exists $mod{rep} && $type eq 'm' ? '('
					  :                                    '(?>';
	my $reppostcontrolcode = $repcontrol && $type eq 'm'
				? '$Perl6::Rules::count=0;' : '';
	my $reppostcontrolpat = $repcontrol ? '|\z(?{$Perl6::Rules::count=0})(?!)' : '';

	error('The :nth modifier can only be used with m/.../ or s/.../.../')
		if exists $mod{nth} && $type ne 'm' && $type ne 's';
	error('The :x modifier can only be used with m/.../ or s/.../.../')
		if exists $mod{rep} && $type ne 'm' && $type ne 's';

    # "pre" modifiers are things like \G that go at the start of the
    # back-translated Perl5ish regex.
    # "post" modifiers are things like /gimsox that go after the
    # back-translated Perl5ish regex.

    my $pre  = join "", keys %{$mod{pre}};
    my $post = join "", keys %{$mod{post}};


    # Decorate the back-translation and cache...

    my $setup = ($mod{exhaust} || $mod{overlap})
					? ';eval q{@0=()}if!$Perl6::Rules::comb++;'
			  		: "";
    my $cleanup = $mod{exhaust} ?  "(?{Perl6::Rules::Match::_success('next')})(?!)|\\z(??{if(\@0){Perl6::Rules::Match::_success('done');$reppostcontrolcode$priorness}else{${reppostcontrolcode}Perl6::Rules::Match::_failure}\@0?'':'(?!)'})"
                : $mod{overlap} ?  "(?{Perl6::Rules::Match::_success('next','overlap')})(?!)|\\z(??{if(\@0){Perl6::Rules::Match::_success('done');$reppostcontrolcode$priorness}else{${reppostcontrolcode}Perl6::Rules::Match::_failure}\@0?'':'(?!)'})"
                : "(?{Perl6::Rules::Match::_success();$reppostcontrolcode$priorness})$reppostcontrolpat|(?{Perl6::Rules::Match::_failure})(?!)";

    my $trans = "(?xm)$repprecontrol(?{local (\@Perl6::Rules::d0,\%Perl6::Rules::d0);local\$Perl6::Rules::startpos=pos;$setup})($pre(?:@p5pat))$repcontrol$cleanup";

    $rules[$rule_id] = do { no warnings 'regexp'; qr{$trans}; }
        unless $translate || $bad;
	$rule_id++;

    $trans = "$type$ldel$trans$rdel";

    # If there's a replacement string (i.e. it's a substitution)...

    if ($repl) {

        # Find the start and end of the (single) interpolator...
        # (This ought to be done with a nested substitution, in which
        #  case we could allow multiple interpolators)

        my $from_s = index($repl, '$(');
        my $from_l = index($repl, '@(');
        my $to   = rindex($repl, ')');

        # Back-translate the interpolator, if any...

        if ($from_s>=0 && $to>=0) {
            my $len  = $to-$from_s+1;
            substr($repl,$from_s,$len) =
                '@{[scalar(' . substr($repl,$from_s+2,$len-3) . ')]}';
        }
        elsif ($from_l>=0 && $to>=0) {
            my $len  = $to-$from_l+1;
            substr($repl,$from_l,$len) =
                '@{[' . substr($repl,$from_l+2,$len-3) . ']}';
        }

        # Append the replacement string to the back-translated regex...

        $trans .= $repl;
    }

    # Return the back-translated regex, appending any flags...

    return "$trans$post";
}


# Append multiple captures to the same array, changing
# value type as necessary

sub apparray {
    my ($arrayref, $newval) = @_;
    $arrayref = $_[0] = [undef] unless $arrayref and @$arrayref; # EXPERIMENTAL
    debug "Appending ", $newval, " to array";
    for ($arrayref->[-1]) {
           if (!defined)       { $_ = $newval }
        elsif (ref ne 'ARRAY') { $_ = [ $_, $newval ] }
        else                   { push @$_, $newval }
    }
}

# Create entry and subsequently assign multiple captures to the same hash
# element, changing value type as necessary

sub apphash {
    my ($hashref, $newval) = @_;
    debug "Appending ", $newval, " to hash";
    if (!defined $hashref->{""}) {      # "Appending" a key
                                        # ($hash{""} stores current "focus" key
        $hashref->{""} = $newval;
        $hashref->{$newval} = undef;
    }
    else { # Appending a value
        for ($hashref->{$hashref->{""}}) {
               if (!defined)       { $_ = $newval }
            elsif (ref ne 'ARRAY') { $_ = [ $_, $newval ] }
            else                   { push @$_, $newval }
        }
    }
}


# Save a restore internal variable sets on subrules
# (because localized variables "bleed" into qr/.../s that
# are interpolated via (??{...})

my @d0_stack;
our ($startpos, $lastpos, @d0, %d0);

sub save_d0 {
    debug "Saving internal state (", 0+@d0_stack, ")";
    push @d0_stack, [$startpos, $lastpos,\@d0, \%d0];
}

sub restore_d0 {
    ($startpos, $lastpos, *d0, *d0) = @{pop @d0_stack};
    debug "Restoring internal state (", 0+@d0_stack, ")";
}

package Perl6::Rules::Match;

my %data;

sub _failure {
    $0 = bless \(my $anon);
    $data{overload::StrVal $0} = { b=>0, a=>[], h=>{} };
}

sub _success {
    my ($exhaust,$overlap) = (@_,"","");
	return if $overlap && $exhaust ne 'done' && $Perl6::Rules::startpos <= $Perl6::Rules::lastpos;
    $Perl6::Rules::d0[0] = $^N unless defined $Perl6::Rules::d0[0];
    my %hash;
    for my $var (keys %Perl6::Rules::d0) {
        my $sigil = substr($var,0,1);
        my $subsigil = substr($var,1,1);
        if ($sigil eq '$') {
            if ($subsigil eq '?') {     # Internal scalar -> cut off sigils
                $Perl6::Rules::d0{substr($var,2)} =
                    delete $Perl6::Rules::d0{$var};
            }
            else {                      # External scalar -> assign
                eval "$var = q{$Perl6::Rules::d0{$var}}";
            }
        }
        elsif ($sigil eq '@' && $subsigil eq '?') {
            @{$Perl6::Rules::d0{$var}} = grep defined, @{$Perl6::Rules::d0{$var}};
        }
        elsif ($sigil eq '%' && $subsigil eq '?') {
            delete $Perl6::Rules::d0{$var}{''};
        }
        elsif ($subsigil ne '?') {      # External array or hash -> assign
			eval "$var = q{$Perl6::Rules::d0{$var}}";
        }
    }
    while (my ($exvar,$exvarref) = each %{$Perl6::Rules::exvar{scalar}}) {
        $$exvarref = eval $exvar;
    }
    while (my ($exvar,$exvarref) = each %{$Perl6::Rules::exvar{hash}}) {
        %$exvarref = eval $exvar;
        delete $exvarref->{''};
    }
    while (my ($exvar,$exvarref) = each %{$Perl6::Rules::exvar{array}}) {
        @$exvarref = eval $exvar;
    }
    $0 = bless \(my $anon);
    if ($exhaust ne 'done') {
        $data{overload::StrVal $0} = {
            b=>1,
			a=>[@Perl6::Rules::d0],
			h=>{%Perl6::Rules::d0},
			p=>$Perl6::Rules::startpos,
        };
        if ($exhaust) {
            push @0, $0;
            Perl6::Rules::debug "Adding alternative match: ", $0;
            @Perl6::Rules::d0 = ();
            %Perl6::Rules::d0 = ();
			$Perl6::Rules::lastpos = $Perl6::Rules::startpos;
        }
    }
    else {
        $data{overload::StrVal $0} = {
            b=>1, a=>\@0, h=>{}, p=>$Perl6::Rules::startpos,
        };
        Perl6::Rules::debug "Finalizing alternative matches: ", 0+@0;
        $Perl6::Rules::comb=0;
        $Perl6::Rules::lastpos=-1;
    }
}

use overload
    q{bool} => sub { $data{overload::StrVal $_[0]}{b} },
    q{""}   => sub { $data{overload::StrVal $_[0]}{a}[0] },
    q{@{}}  => sub { $data{overload::StrVal $_[0]}{a} },
    q{%{}}  => sub { $data{overload::StrVal $_[0]}{h} },
    fallback => 1,
;

sub _flatten {
    my ($val) = @_;
    if (ref $val eq 'Perl6::Rules::Match') {
        return _flatten({
            'SCALAR'.($val?'(true)':'(false)') => "$val",
            ARRAY  => \@$val,
            HASH   => \%$val,
			POS    => $val->pos,
        });
    }
    elsif (ref $val eq 'ARRAY') {
        return [ map { _flatten($_) } @$val ];
    }
    elsif (ref $val eq 'HASH') {
        return { map { ($_=>_flatten($val->{$_})) } keys %$val };
    }
    elsif (!defined $val) {
        return "";
    }
    else {
        return $val;
    }
}

sub pos {
	my ($self) = @_;
	return $data{overload::StrVal $self}{p};
}

sub dump {
    my ($self,$level) = @_;
    use YAML;
    local ($YAML::UseAliases, $YAML::UseHeader)
          =       0,          0;
    my $dump = Dump _flatten($self);
    return $dump if defined wantarray;
    print $dump;
}

# Placate the mysterious regex gods...

$Perl6::Rules::lastpos=-1;
$Perl6::Rules::startpos=-1;
Perl6::Rules::save_d0;
_success();
Perl6::Rules::restore_d0;

1;

__END__