File Coverage

blib/lib/PPIx/Regexp/Token/CharClass/Simple.pm

Criterion	Covered	Total	%
statement	73	73	100.0
branch	29	34	85.2
condition			n/a
subroutine	15	15	100.0
pod	3	3	100.0
total	120	125	96.0

=head1 NAME

PPIx::Regexp::Token::CharClass::Simple - This class represents a simple character class

=head1 SYNOPSIS

 use PPIx::Regexp::Dumper;
 PPIx::Regexp::Dumper->new( 'qr{\w}smx' )
     ->print();

=head1 INHERITANCE

C is a
L.

C has no descendants.

=head1 DESCRIPTION

This class represents one of the simple character classes that can occur
anywhere in a regular expression. This includes not only the truly
simple things like \w, but also Unicode properties, including properties
with wildcard values.

=head1 METHODS

This class provides no public methods beyond those provided by its
superclass.

=cut

package PPIx::Regexp::Token::CharClass::Simple;

use strict;
use warnings;

use base qw{ PPIx::Regexp::Token::CharClass };

use PPIx::Regexp::Constant qw{
    COOKIE_CLASS
    LITERAL_LEFT_CURLY_REMOVED_PHASE_1
    LITERAL_LEFT_CURLY_REMOVED_PHASE_2
    MINIMUM_PERL
    TOKEN_LITERAL
    TOKEN_UNKNOWN
    @CARP_NOT
};

our $VERSION = '0.087_01';

use constant UNICODE_PROPERTY_LITERAL_VALUE => qr/
		\{ \s* \^? \w [\w:=\s-]* \} |
		[CLMNPSZ]	# perluniprops for 5.26.1
    /smx;
use constant UNICODE_PROPERTY_LITERAL =>
    qr/ \A \\ [Pp] (?:
	@{[ UNICODE_PROPERTY_LITERAL_VALUE ]}
    ) /smx;

# CAVEAT: The following regular expression, despite its name, matches
# ALL unicode property values. To actually match a wildcard property you
# must first eliminate anything that matches UNICODE_PROPERTY_LITERAL or
# UNICODE_PROPERTY_NAME_MATCH
use constant UNICODE_PROPERTY_WILDCARD =>
    qr/ \A \\ [Pp] \{ \s* [\w\s-]+ [:=] [^}]+ \} /smx;

use constant UNICODE_PROPERTY_NAME_MATCH =>
    qr< \A \\ [Pp] \{ \s* na (?: me? )? [:=] / [^/]+ / \} >smx;

use constant UNICODE_PROPERTY =>
    qr/ @{[ UNICODE_PROPERTY_LITERAL ]} |
	@{[ UNICODE_PROPERTY_NAME_MATCH ]} |
	@{[ UNICODE_PROPERTY_WILDCARD ]} /smx;

{

    my %kind_of_match = (
	p	=> 'with',
	P	=> 'without',
    );

    my %explanation = (
	'.'	=> 'Match any character',
	'\\C'	=> 'Match a single octet (removed in 5.23.0)',
	'\\D'	=> 'Match any character but a decimal digit',
	'\\H'	=> 'Match a non-horizontal-white-space character',
	'\\N'	=> 'Match any character but a new-line character',
	'\\R'	=> 'Match a generic new-line character',
	'\\S'	=> 'Match non-white-space character',
	'\\V'	=> 'Match a non-vertical-white-space character',
	'\\W'	=> 'Match non-word character',
	'\\X'	=> 'Match a Unicode extended grapheme cluster',
	'\\d'	=> 'Match decimal digit',
	'\\h'	=> 'Match a horizontal-white-space character',
	'\\s'	=> 'Match white-space character',
	'\\v'	=> 'Match a vertical-white-space character',
	'\\w'	=> 'Match word character',
    );

    sub __explanation {
	return \%explanation;
    }

    sub explain {
	my ( $self ) = @_;
	if ( $self->content() =~ m/ \A \\ ( [Pp] ) ( [{] .* [}] | . ) \z /smx ) {
	    my ( $kind, $prop ) = ( $1, $2 );

	    my $literal = ( $prop =~
		m/ \A @{[ UNICODE_PROPERTY_LITERAL_VALUE ]} \z /smx );

	    if ( 1 < length $prop ) {
		$prop =~ s/ \A [{] //smx;
		$prop =~ s/ [}] \z //smx;
	    }

	    $literal
		and return sprintf
		q,
		$kind_of_match{$kind}, $prop;

	    return sprintf
		q,
		$kind_of_match{$kind}, $prop;
	}
	return $self->SUPER::explain();
    }

}

##=head2 is_case_sensitive
##
##This override of the superclass method returns true for Unicode
##properties that specify case, and false (but defined) for all
##other character classes.
##
##The classes that specify case are documented in
##L.
##
##B This method returns false (but defined) for user-defined
##Unicode properties. It should return C. This bug B be fixed
##if I find a way to identify all system-defined Unicode properties.
##
##=cut
##
##sub is_case_sensitive {
##    my ( $self ) = @_;
##    exists $self->{is_case_sensitive}
##	and return $self->{is_case_sensitive};
##    return ( $self->{is_case_sensitive} = $self->_is_case_sensitive() );
##}

##{
##    my %case_sensitive = map { $_ => 1 } qw{
##        generalcategory=lowercaseletter generalcategory=ll
##	    gc=lowercaseletter gc=ll
##        generalcategory=titlecaseletter generalcategory=lt
##	    gc=titlecaseletter gc=lt
##        generalcategory=uppercaseletter generalcategory=lu
##	    gc=uppercaseletter gc=lu
##	lowercaseletter lowercase lower ll
##	titlecaseletter titlecase title lt
##	uppercaseletter uppercase upper lu
##	lowercase=y lower=y lowercase=n lower=n
##	titlecase=y title=y titlecase=n title=n
##	uppercase=y upper=y uppercase=n upper=n
##    };
##
##    sub _is_case_sensitive {
##	my ( $self ) = @_;
##	my $content = $self->content();
##	$content =~ m/ \A \\ p [{] ( .* ) [}] /smxi
##	    or return 0;
##	$content = lc $1;
##	$content =~ s/ \A ^ //smx;
##	$content =~ s/ [\s_-] //smxg;
##	$content =~ s/ \A is //smx;
##	$content =~ s/ : /=/smxg;
##	$content =~ s/ = (?: yes | t | true ) \b /=y/smxg;
##	$content =~ s/ = (?: no | f | false ) \b /=n/smxg;
##	return $case_sensitive{$content} || 0;
##    }
##
##}

{

    my %introduced = (
	'\\h'	=> '5.009005',	# Before this, parsed as 'h'
	'\\v'	=> '5.009005',	# Before this, parsed as 'v'
	'\\H'	=> '5.009005',	# Before this, parsed as 'H'
	'\\N'	=> '5.011',	# Before this, an error.
	'\\V'	=> '5.009005',	# Before this, parsed as 'V'
	'\\R'	=> '5.009005',
	'\\C'	=> '5.006',
	'\\X'	=> '5.006',
    );

    sub perl_version_introduced {
	my ( $self ) = @_;
	my $content = $self->content();
	if ( defined( my $minver = $introduced{$content} ) ) {
	    return $minver;
	}
	# I must have read perl5113delta and thought this
	# represented the change they were talking about, but I sure
	# don't see it now. So, until things become clearer ...
#	$content =~ m/ \G .*? [\s=-] /smxgc
#	    and return '5.011003';
	$content  =~ UNICODE_PROPERTY_LITERAL
	    and return '5.006001';
	$content =~ UNICODE_PROPERTY_NAME_MATCH
	    and return '5.031010';
	$content =~ UNICODE_PROPERTY_WILDCARD
	    and return '5.029009';
	return MINIMUM_PERL;
    }

}

{
    my %removed	 = (
	'\\C'	=> '5.023',	# Before this, matched an octet
    );

    sub perl_version_removed {
	my ( $self ) = @_;
	return $removed{ $self->content() };
    }
}

# This is one of the larger complications of
# https://rt.perl.org/Public/Bug/Display.html?id=128213
# where it transpired that un-escaped literal left curlies were not
# giving warnings/errors in /.{/, /\p{...}{/, and /\P{...}{/, but were
# for all the others that bin into this class (e.g. /\s{/).
# Note that the perldelta for 5.25.1 and 5.26.0 do not acknowledge tha
# phased deprecation, and pretend that everything was done on the phase
# 1 schedule. This appears to be deliberate per
# https://rt.perl.org/Ticket/Display.html?id=131352
sub __following_literal_left_curly_disallowed_in {
    my ( $self ) = @_;
    q<.> eq ( my $content = $self->content() )
	and return LITERAL_LEFT_CURLY_REMOVED_PHASE_2;
    $content =~ m/ \A \\ p \{ /smxi
	and return LITERAL_LEFT_CURLY_REMOVED_PHASE_2;
    return LITERAL_LEFT_CURLY_REMOVED_PHASE_1;
}

sub __PPIX_TOKENIZER__regexp {
    my ( undef, $tokenizer, $character ) = @_;

    my $in_class = $tokenizer->cookie( COOKIE_CLASS );

    if ( $character eq '.' ) {
	$in_class
	    and return $tokenizer->make_token( 1, TOKEN_LITERAL );
	return 1;
    }

    if ( my $accept = $tokenizer->find_regexp(
	    qr{ \A \\ [wWsSdDvVhHXRNC] }smx
	) ) {
	if ( $in_class ) {
	    my $match = $tokenizer->match();
	    # As of Perl 5.11.5, [\N] is a fatal error.
	    '\\N' eq $match
		and return $tokenizer->make_token(
		    $accept, TOKEN_UNKNOWN, {
			    error	=> '\\N invalid inside character class',
			},
		    );
	    # \R is not recognized inside a character class. It
	    # eventually ends up as a literal.
	    '\\R' eq $match and return;
	}
	return $accept;
    }

    if ( my $accept = $tokenizer->find_regexp( UNICODE_PROPERTY ) ) {
	return $accept;
    }

    if ( my $accept = $tokenizer->find_regexp( qr< \A \\ p [{] \s* [}] >smx )
    ) {
	return $tokenizer->make_token( $accept, TOKEN_UNKNOWN, {
		error => 'Empty \\p{} is an error',
	    },
	);
    }

    return;
}

1;

__END__