File Coverage

blib/lib/Regexp/Genex.pm

Criterion	Covered	Total	%
statement	166	222	74.7
branch	25	36	69.4
condition	2	6	33.3
subroutine	35	49	71.4
pod	4	4	100.0
total	232	317	73.1

package Regexp::Genex;
use strict;
use warnings;
use Carp ();

our $VERSION = '0.07';

our $MAX_QUANTIFIER = 20;
our $rx;
our $in = '';
our @stack = {
	dot_nl => 0,   # /s modifier
	multiline => 0,# /m modifier
	anycase => 0,  # /i modifier
};


package Regexp::Genex::Element;
use List::Util qw(shuffle);

my $top = -1;

# global status
sub anycase {
	return $stack[$top]{anycase} unless defined $_[1];
	$stack[$top]{anycase} = $_[1];
}

sub dot_nl  {
	return $stack[$top]{dot_nl} unless defined $_[1];
	$stack[$top]{dot_nl} = $_[1];
}

sub multiline  {
	return $stack[$top]{multiline} unless defined $_[1];
	$stack[$top]{multiline} = $_[1];
}

sub adjust_mods {
	my ($self, $on, $off) = @_;
	$self->anycase(1)    if $on  =~ /i/;
	$self->anycase(0)    if $off =~ /i/;
	$self->dot_nl(1)     if $on  =~ /s/;
	$self->dot_nl(0)     if $off =~ /s/;
	$self->multiline(1)  if $on  =~ /m/;
	$self->multiline(0)  if $off =~ /m/;
}

sub push_state {
	my ($self) = shift;
	push @stack, {
		# current state overwriten by new state
		anycase => $self->anycase,
		dot_nl => $self->dot_nl,
		multiline => $self->multiline,
		quant => $stack[$top]{quant},
		@_, # new state
	};
}
sub pop_state {
	my ($self) = @_;
	pop @stack or Carp::confess "Pop without a push";
}

sub add {
	my ($self, $code, $comment) = @_;

	$code = $in.$code;
	if((my $len = length($code)) < 40) {
		# comment after code at col 40
		$rx .= $code;
		if(defined $comment) {
			$rx .= (' 'x(40-$len))."## $comment\n";
		} else {
			$rx .= "\n";
		}
	} else {
		# comment on line before code
		$rx .= "\n".(' 'x40)."## $comment (below)\n" if defined $comment;
		$rx .= "$code\n\n";
	}
}

sub safe_quant {
	my ($self, $quant) = @_;
	# dodge perl's optimizations
	my $nq = $quant;
	#$nq =~ s/\*/{0,$MAX_QUANTIFIER}/;
	#$nq =~ s/\+/{1,$MAX_QUANTIFIER}/;
	return $nq;
}

sub case_mod {
	# i modifier in effect, use \u \L etc to muck with string at rx creation
	return (!$_[0]->anycase) ? '' : ( "", qw(\U \L \u \l) )[rand 5];
}

# $; = undef  ???
# keys = all characters, values = quoted string equivalent
# (String::Escape \80 != perl \x80)
my %all_chars = map { chr($_), '"'.escape(chr($_)).'"' } 0..255;

# regex to pick random
# x "string" =~ /(?=(?>^.*(?{$n=int rand$+[0]})))(??{".{$n}"})(.)/s
sub class_chars {
	my ($self, $qr_class) = @_;

	my @chars = map { $all_chars{$_} }
				grep { $_ =~ $qr_class }
				keys %all_chars;

	if(@chars > 10) { # too big, sample
		@chars = shuffle(@chars);
		# XXX can't produce anything possible for regex .{$n+1} exhausts range
		$#chars = 4;
		# could put %all_chars generation in regex and do \d filter
	}
	return scalar(@chars), @chars;
}

sub escape {
	local($_) = shift;
	s/([\\{}"@\$])/\\$1/g; # protect " string interpolation & {} regex parse
	s/([^[:graph:] ])/sprintf "\\%03o", ord($1)/eg;
	#s/(.*)/"$1"/s;
	return $_;
}
#use String::Escape qw(qprintable);
#print qprintable($_)," = ",escape($_),"\n"
#	for grep { $_ ne eval escape($_) } map chr, 0..255;

package Regexp::Genex::flags;
sub new {
	my $self = $_[0]->SUPER::new(@_[1..$#_]);

	#my ($on, $off) = @_[1,2];
	# ignore x, always on for us
	# off overrides: perl -le 'print "A" =~ /(?i-i)a/'
	$self->adjust_mods(@_[1,2]);

	$self->add('',$self->string);
}

package Regexp::Genex::group;
sub new {
	my $self = $_[0]->SUPER::new(@_[1..$#_]);

	$self->push_state(quant => $self->quant);
	# modify new state
	$self->adjust_mods(@_[1,2]);

	$self->add("(?:", $self->string);
	$in .= ' '; # ->add_indent
	return $self;
}

package Regexp::Genex::capture;
my $number = 0;
sub new {
	my $self = $_[0]->SUPER::new(@_[1..$#_]);
	$number++;
	$self->push_state(quant => $self->quant);

	$self->add("(","( -> \$$number");
	$in .= ' ';
	return $self;
}

package Regexp::Genex::close;
# group, capture, perl code bit
# Pcond Pcut Pahead Pbehind Pgroup Pcapture Pcode Plater
sub new {
    my $self = $_[0]->SUPER::new(@_[1..$#_]);
    chop($in);
	no warnings 'uninitialized';
	my $q = "$_[1]$_[2]";
	my $nq = $self->safe_quant($q);
    $self->add(")$nq",")$q");
	$self->pop_state;
    return $self;
}

package Regexp::Genex::alt;
sub new {
	my $self = $_[0]->SUPER::new(@_[1..$#_]);
	$self->add('|','|');
	return $self;
}

package Regexp::Genex::backref;
#  perl -W -MRegexp::Genex -e 'Regexp::Genex::rx(qr/(.)=\1{0,2}/)'
sub new {
	my $self = $_[0]->SUPER::new(@_[1..$#_]);
	my $var = $_[1];
	my $q = $self->quant;
	my $nq = $self->safe_quant($q);
	my $text = $self->text;

	# the offsets are to the target string but we take that section of $^R
	$self->add(
		'(?: .{1} (?{ $^R.substr($^R,$-[1],$+[1]-$-[1]) }) )'.$nq, $text.$q
	);
	return $self;
}

package Regexp::Genex::text;
sub new {
	my $self = $_[0]->SUPER::new(@_[1..$#_]);
	my $text = $self->text;
	my $q = $self->quant;
	my $nq = $self->safe_quant($q);
	my $case_mod = $self->case_mod;

	my $len = length($text);
	$text = Regexp::Genex::Element::escape($text);
	$self->add("(?: .{$len} (?{ \$^R.\"$case_mod$text\" }) )$nq", $text.$q);
	return $self;
}

package Regexp::Genex::oct;
sub new {
	my $self = $_[0]->SUPER::new(@_[1..$#_]);
	my $text = $self->text;
	my $q = $self->quant;
	my $nq = $self->safe_quant($q);
	my $case_mod = $self->case_mod;

	$self->add("(?: . (?{ \$^R.\"$case_mod$text\" }) )$nq", $text.$q);
	return $self;
}

package Regexp::Genex::hex;
sub new {
	my $self = $_[0]->SUPER::new(@_[1..$#_]);
	my $text = $self->text;
	my $q = $self->quant;
	my $nq = $self->safe_quant($q);
	my $case_mod = $self->case_mod;

	$self->add("(?: . (?{ \$^R.\"$case_mod$text\" }) )$nq", $text.$q);
	return $self;
}

package Regexp::Genex::utf8hex;
sub new {
	my $self = $_[0]->SUPER::new(@_[1..$#_]);
	my $text = $self->text;
	my $q = $self->quant;
	my $nq = $self->safe_quant($q);
	my $case_mod = $self->case_mod;

	$self->add("(?: . (?{ \$^R.\"$case_mod$text\" }) )$nq", $text.$q);
	return $self;
}

package Regexp::Genex::ctrl;
sub new {
	my $self = $_[0]->SUPER::new(@_[1..$#_]);
	my $text = $self->text;
	my $q = $self->quant;
	my $nq = $self->safe_quant($q);
	my $case_mod = $self->case_mod;

	$self->add("(?: . (?{ \$^R.\"$case_mod$text\" }) )$nq", $text.$q);
	return $self;
}

package Regexp::Genex::named;
sub new {
	my $self = $_[0]->SUPER::new(@_[1..$#_]);
	my $text = $self->text;
	my $q = $self->quant;
	my $nq = $self->safe_quant($q);
	my $case_mod = $self->case_mod;

	$self->add("(?: . (?{ \$^R.\"$case_mod$text\" }) )$nq", $text.$q);
	return $self;
}

package Regexp::Genex::Cchar;
sub new {
	my $self = $_[0]->SUPER::new(@_[1..$#_]);
	my $text = $self->text;
	my $q = $self->quant;
	my $nq = $self->safe_quant($q);
	my $case_mod = $self->case_mod;

	$self->add("(?: . (?{ \$^R.\"$case_mod$text\" }) )$nq", $text.$q);
	return $self;
}

package Regexp::Genex::slash;
sub new {
	my $self = $_[0]->SUPER::new(@_[1..$#_]);
	my $text = $self->text;
	my $q = $self->quant;
	my $nq = $self->safe_quant($q);
	my $case_mod = $self->case_mod;

	$self->add("(?: . (?{ \$^R.\"$case_mod$text\" }) )$nq", $text.$q);
	return $self;
}

package Regexp::Genex::any;
sub new {
	my $self = $_[0]->SUPER::new(@_[1..$#_]);
	my $q = $self->quant;
	my $nq = $self->safe_quant($q);

	#my ($nl, $n) = ('', 3);
	#($nl, $n) = (',"\n"', 4) if($self->dot_nl);
	my ($n, @chars) = ($self->dot_nl)
		? $self->class_chars(qr/./s)
		: $self->class_chars(qr/./);

	local($") = ",";
	$self->add("(?: . (?{ \$^R.(@chars)[rand $n] }) )$nq", ".$q");
	#$self->add("(?: . (?{ \$^R.('.','x','X'$nl)[rand $n] }) )$nq",".$q");
	return $self;
}

package Regexp::Genex::macro;
sub new {
	my $self = $_[0]->SUPER::new(@_[1..$#_]);
	my $text = $self->text;
	my $q = $self->quant;
	my $nq = $self->safe_quant($q);

	# \d \D \w \W \s \S
	my ($n, @chars) = $self->class_chars(qr/$text/);

	local($") = ",";
	$self->add("(?: . (?{ \$^R.(@chars)[rand $n] }) )$nq", "$text$q");
	return $self;
}

package Regexp::Genex::class;
sub new {
	my $self = $_[0]->SUPER::new(@_[1..$#_]);
	my $text = $self->text;
	my $q = $self->quant;
	my $nq = $self->safe_quant($q);

	# [^dfads]
	my ($n, @chars) = $self->class_chars(qr/$text/);

	local($") = ",";
	$self->add("(?: . (?{ \$^R.(@chars)[rand $n] }) )$nq", "$text$q");
	return $self;
}

# TODO
package Regexp::Genex::anchor;
# $ is a lookahead \n|\z
# \A \z \Z ^ $ \G
# ^ $ are /s sensitive (multiline)
sub new {
    Carp::croak("Genex: Anchors not implemented ^ \$ \\A \\Z \\z \\G\n");
}
package Regexp::Genex::lookahead;
# could run look ahead code at the end and check the output...
# might be no match possible with random string selections
sub new {
    Carp::croak("Genex: Look-ahead not implemented (?=...) (?!...)\n");
}
package Regexp::Genex::lookbehind;
# can look behind! match against the string we have made or fail
sub new {
    Carp::croak("Genex: Look-behind not implemented (?<=...) (?
}

package Regexp::Genex::cond;
# probably ok, except for the close complications
# (?(1) ... ) should test our $1
sub new {
	Carp::croak("Genex: Cut not implemented (?(...)...|...)\n");
}

package Regexp::Genex::cut;
# probably ok, except for the close complications
sub new {
	Carp::croak("Genex: Cut not implemented (?>...)\n");
}

package Regexp::Genex::code;
# trashes $^R (stash it somewhere else locally)
# could use condition to avoid $^R trashing (?( (?{...}) ) )
sub new {
	Carp::croak("Genex: Code assertion not implemented (?{...})\n");
}

package Regexp::Genex::later; # (??{})
# probably ok, except for the close complications
# may need original modifier state (esp. /x)
sub new {
	Carp::croak("Genex: Delayed regex not implemented (??{...})\n");
}

#sub new {
#	Carp::carp("Delayed regex not handled (??{...})");
#	my $self = $_[0]->SUPER::new(@_[1..$#_]);
#	my $text = $self->text;
#	my $q = $self->quant;
#	my $nq = $self->safe_quant($q);
#
#	# HACK needs no_close handling in close->new
#    push @stack, {
#        anycase => $self->anycase, dot_nl => $self->dot_nl,
#        q => $stack[$top]{q}, nq => $stack[$top]{nq},
#		no_close => 1,
#    };
#
#	$in .= ' ';
#
#	$self->add($text.$nq, $text.$q);
#	return $self;
#}

package Regexp::Genex;
use YAPE::Regex 'Regexp::Genex';

require Exporter;
our @ISA = qw(Exporter YAPE::Regex);
our @EXPORT_OK = qw(strings strings_rx generator generator_rx);
our %EXPORT_TAGS = ( 'all' => \@EXPORT_OK );

our $DEFAULT_LEN = 10;

sub strings {
	my ($rx_arg, $len) = @_;
	my $rx_str = strings_rx($rx_arg);

	$len ||= $DEFAULT_LEN;

	use re 'eval';
	#eval 'use re "debug"';
	("a"x$len) =~ qr/$rx/x;

	return @_;
}

sub _main_rx {
    my $in_rx = shift;

	$rx = "";
	my $orig_rx = Regexp::Genex::Element::escape($in_rx);
	Regexp::Genex::Element->add('', "Orignal: $orig_rx");

	# The ^ means the target length can limit output
	Regexp::Genex::Element->add(
		'^(?> (?{ @_ = (); "" }) )', 'Initialize $^R & @_');
	$in = '  ';

    my $yape = Regexp::Genex->new($in_rx);
    $yape->parse; die $yape->error if $yape->error;

	$in = '';
	# left in $rx
}

sub strings_rx {
    my $in_rx = shift;

	_main_rx($in_rx);

	Regexp::Genex::Element->add(
		'(?{ push @_, $^R }) (?!)', 'Save & backtrack');

	return $rx;
}

sub generator_rx {
	my $in_rx = shift;

	_main_rx($in_rx);

	Regexp::Genex::Element->add(
		'(?(?{ @_ = $^R if $c++ == $n; }) (?=) | (?!) )',
		'Replay up to $n then stop');

	return $rx;
}

# perl -MRegexp::Genex=:all -le '$i = generator(qr/ab*?/); print $i->() for 1..4; print $i->(1)'
sub generator {
	my ($rx_arg, $len) = @_;
	$len ||= $DEFAULT_LEN;
	my $rx_str = generator_rx($rx_arg);

	# These vars are captured both by the closure and the regex
	my $n = 0;
	my $c;

	use re 'eval';
	#eval "use re 'debug'";
	my $qr = qr/$rx_str/x;

	return sub {
		$n = shift if defined $_[0]; # reset's with argument

		$c = 0; # reset found counter
		('a'x$len) =~ $qr;
		$n++;   # track next to show
		return $_[0];
	};
}

1;
__END__