File Coverage

blib/lib/Regexp/English.pm

Criterion	Covered	Total	%
statement	113	113	100.0
branch	32	32	100.0
condition	2	2	100.0
subroutine	24	24	100.0
pod	8	8	100.0
total	179	179	100.0

package Regexp::English;

use strict;
use warnings;

use Exporter 'import';
use vars qw( @export @EXPORT_OK %EXPORT_TAGS $VERSION );

$VERSION = '1.01';

use overload '""' => \&compile;
use Scalar::Util 'blessed';

# REGEX: storage for the raw regex
# STORE: storage for bound references (see remember())
# STACK: used to nest groupings
use constant REGEX => 0;
use constant STORE => 1;
use constant STACK => 2;

# the key is the name of the method to create
# 	symbol is the regex token this represents
#	plural is the name of the shortcut method for $symbol+, i.e. \w+
#	non is the name of the negated token, its shortcut, and a plural, if needed
my %chars = (
	word_char =>
	{
		symbol => '\w',
		plural => 'word_chars',
		non    => [ 'non_word_char', '\W', 'non_word_chars' ],
	},
	whitespace_char =>
	{
		symbol => '\s',
		plural => 'whitespace_chars',
		non    => [ 'non_whitespace_char', '\S', 'non_whitespace_chars' ],
	},
	digit =>
	{
		symbol => '\d',
		plural => 'digits',
		non    => [ 'non_digit', '\D', 'non_digits' ],
	},
	word_boundary =>
	{
		symbol => '\b',
		non    => [ 'non_word_boundary', '\B' ],
	},
	end_of_string =>
	{
		symbol => '\Z',
		non    => [ 'very_end_of_string', '\z' ],
	},
	beginning_of_string   => { symbol => '\A', },
	end_of_previous_match => { symbol => '\G', },

	# XXX: non for these ?
	tab =>
	{
		symbol => '\t',
		plural => 'tabs',
		non    => [ 'non_tab', '[^\t]' ],
	},

	# implies /s modifier
	newline =>
	{
		symbol => '\n',
		plural => 'newlines',
		non    => [ 'non_newline', '(?s)[^\n]' ],
	},

	carriage_return =>
	{
		symbol => '\r',
		plural => 'carriage_returns',
		non    => [ 'non_carriage_return', '[^\r]' ],
	},

	form_feed =>
	{
		symbol => '\f',
		plural => 'form_feeds',
		non    => [ 'non_form_feed', '[^\f]' ],
	},

	'alarm' =>
	{
		symbol => '\a',
		plural => 'alarms',
		non    => [ 'non_alarm', '[^\a]' ],
	},
	escape =>
	{
		symbol => '\e',
		plural => 'escapes',
		non    => [ 'non_escape', '[^\e]' ],
	},
	start_of_line => { symbol => '^', },
	end_of_line   => { symbol => '$', },
);

sub _chars
{
	my $symbol = shift;

	return sub
	{
		# cannot use $_[0] here, as it trips the overload
		# that can mess with remember/end groups
		return $symbol unless @_;

		my $self = shift;
		$self    = $self->new() unless blessed( $self );

		$self->[REGEX] .= $symbol;
		return $self;
	};
}

my @char_tags;

for my $char ( keys %chars )
{
	push @char_tags, $char;
	_install( $char, _chars( $chars{$char}{symbol} ) );

	if ( $chars{$char}{plural} )
	{
		_install( $chars{$char}{plural}, _chars( $chars{$char}{symbol} . '+' ));
		push @char_tags, $chars{$char}{plural};
	}

	if ( $chars{$char}{non} )
	{
		my ( $nonname, $symbol, $pluralname ) = @{ $chars{$char}{non} };
		_install( $nonname, _chars($symbol) );
		push @char_tags, $nonname;
		if ($pluralname)
		{
			_install( $pluralname, _chars( $symbol . '+' ) );
			push @char_tags, $pluralname;
		}
	}
}

# tested in t/quantifiers
# XXX:
#	the syntax for minimal/optional is slightly awkward
my %quantifiers =
(
	zero_or_more => '*',
	multiple     => '+',
	minimal      => '?',
	optional     => '?',
);

for my $quantifier ( keys %quantifiers )
{
	_install( $quantifier,
		_standard( '(?:', '', $quantifiers{$quantifier} . ')' ), 1 );
}

# tested in t/groupings
my %groupings =
(
	after           => '(?<=',
	group           => '(?:',
	comment         => '(?#',
	not_after       => '(?
	followed_by     => '(?=',
	not_followed_by => '(?!',
);

for my $group ( keys %groupings )
{
	_install( $group, _standard( $groupings{$group}, '', '' ), 1 );
}

sub _standard
{
	my ( $group, $sep, $symbol ) = @_;

	$symbol ||= ')';

	return sub
	{
		if ( eval { $_[0]->isa( 'Regexp::English' ) } )
		{
			my $self        = shift;
			$self->[REGEX] .= $group;

			if (@_)
			{
				$self->[REGEX] .= join( "$sep", @_ ) . $symbol;
			}
			else
			{
				push @{ $self->[STACK] }, $symbol;
			}
			return $self;
		}
		return $group . join( $sep, @_ ) . $symbol;
	};
}

# can't be used with standard because of quotemeta()
sub literal
{
	my $self        = shift;
	$self->[REGEX] .= quotemeta( +shift );
	return $self;
}

sub _install
{
	my ( $name, $sub, $export ) = @_;
	no strict 'refs';
	*{$name} = $sub;
	push @export,    "&$name" if $export;
	push @EXPORT_OK, "&$name";
}

_install(
	'or',
	sub {
		if ( eval { $_[0]->isa( 'Regexp::English' ) } )
		{
			my $self = shift;
			if (@_)
			{
				$self->[REGEX] .= '(?:' . join( '|', @_ ) . ')';
			}
			else
			{
				$self->[REGEX] .= '|';
			}
			return $self;
		}
		return '(?:' . join( '|', @_ ) . ')';
	},
	1
);

_install( 'class', _standard( '[', '', ']' ), 1 );

# XXX - not()

sub remember
{
	my $self = shift;
	$self    = $self->new() unless blessed( $self );

	# the first element may be a reference, so stick it in STORE
	if ( ref( $_[0] ) eq 'SCALAR' )
	{
		push @{ $self->[STORE] }, shift;
	}

	# if there are other arguments, add them to REGEX
	if (@_)
	{
		$self->[REGEX] .= '(' . join( '', @_ ) . ')';

		# otherwise, this is the opening op of a multi-call remember block
		# XXX: might store calling line for verbose debugging
	}
	else
	{
		$self->[REGEX] .= '(';
		push @{ $self->[STACK] }, ')';
	}

	return $self;
}

sub end
{
	my ( $self, $levels ) = @_;
	$levels               = 1 unless defined $levels;

	unless ( @{ $self->[STACK] } )
	{
		require Carp;
		Carp::confess( 'end() called without remember()' );
	}

	$self->[REGEX] .= pop @{ $self->[STACK] } for 1 .. $levels;

	return $self;
}

sub new
{
	bless( [ '', [], [] ], $_[0] );
}

sub match
{
	my $self       = shift;
	$self->[REGEX] = $self->compile();

	if ( @{ $self->[STORE] } )
	{
		return $self->capture( $_[0] =~ $self->[REGEX] );
	}
	else
	{
		if ( wantarray() )
		{
			return $_[0] =~ $self->[REGEX];
		}
		else
		{
			return ( $_[0] =~ $self->[REGEX] )[0];
		}
	}
}

sub capture
{
	my $self = shift;

	for my $ref ( @{ $self->[STORE] } )
	{
		$$ref = shift @_;
	}
	if ( wantarray() )
	{
		return map { $$_ } @{ $self->[STORE] };
	}
	else
	{
		return ${ ${ $self->[STORE] }[0] };
	}
}

sub compile
{
	my $self = shift;

	if ( my $num = @{ $self->[STACK] } )
	{
		$self->end($num);
	}
	return qr/$self->[REGEX]/;
}

sub debug
{
	my $self = shift;
	return $self->[REGEX];
}

%EXPORT_TAGS =
(
	all      => [ @char_tags, @export ],
	chars    => \@char_tags,
	standard => \@export,
);

1;

__END__