File Coverage

blib/lib/PPIx/Regexp/Node/Range.pm
Criterion Covered Total %
statement 38 39 97.4
branch 10 14 71.4
condition 2 3 66.6
subroutine 8 8 100.0
pod 1 1 100.0
total 59 65 90.7


line stmt bran cond sub pod time code
1             =head1 NAME
2              
3             PPIx::Regexp::Node::Range - Represent a character range in a character class
4              
5             =head1 SYNOPSIS
6              
7             use PPIx::Regexp::Dumper;
8             PPIx::Regexp::Dumper->new( 'qr{[a-z]}smx' )
9             ->print();
10              
11             =head1 INHERITANCE
12              
13             C is a
14             L.
15              
16             C has no descendants.
17              
18             =head1 DESCRIPTION
19              
20             This class represents a character range in a character class. It is a
21             node rather than a structure because there are no delimiters. The
22             content is simply the two literals with the '-' operator between them.
23              
24             =head1 METHODS
25              
26             This class provides no public methods beyond those provided by its
27             superclass.
28              
29             =cut
30              
31             package PPIx::Regexp::Node::Range;
32              
33 9     9   59 use strict;
  9         19  
  9         251  
34 9     9   42 use warnings;
  9         37  
  9         249  
35              
36 9     9   48 use base qw{ PPIx::Regexp::Node };
  9         28  
  9         789  
37              
38 9         5635 use PPIx::Regexp::Constant qw{
39             MSG_PROHIBITED_BY_STRICT
40             @CARP_NOT
41 9     9   59 };
  9         16  
42              
43             our $VERSION = '0.087_01';
44              
45             sub explain {
46 1     1 1 3 my ( $self ) = @_;
47 1 50       9 my $first = $self->schild( 0 )
48             or return $self->__no_explanation();
49 1 50       5 my $last = $self->schild( -1 )
50             or return $self->__no_explanation();
51 1         7 return sprintf q,
52             $first->content(), $last->content();
53             }
54              
55             sub __PPIX_LEXER__finalize {
56 13     13   37 my ( $self, $lexer ) = @_;
57              
58 13         58 my $rslt = $self->SUPER::__PPIX_LEXER__finalize( $lexer );
59              
60 13 100       79 if ( $lexer->strict() ) {
61             # If strict is in effect, we're an error unless both ends of the
62             # range are portable.
63 3         31 my @kids = $self->schildren();
64 3         8 delete $self->{_range_start}; # Context for compatibility.
65 3         9 foreach my $inx ( 0, -1 ) {
66 6         13 my $kid = $kids[$inx];
67             # If we're not a literal, we can not make the test, so we
68             # blindly accept it.
69 6 50       22 $kid->isa( 'PPIx::Regexp::Token::Literal' )
70             or next;
71 6         20 my $content = $kid->content();
72 6 100 66     42 $content =~ m/ \A (?: [[:alnum:]] | \\N\{ .* \} ) \z /smx
73             and $self->_range_ends_compatible( $content )
74             or return $self->_prohibited_by_strict( $rslt );
75             }
76             }
77              
78 11         30 return $rslt;
79             }
80              
81             sub _prohibited_by_strict {
82 2     2   9 my ( $self, $rslt ) = @_;
83 2         6 delete $self->{_range_start};
84 2         29 $rslt += $self->__error(
85             join( ' ', 'Non-portable range ends', MSG_PROHIBITED_BY_STRICT ),
86             perl_version_introduced => '5.023008',
87             );
88 2         11 return $rslt;
89             }
90              
91             sub _range_ends_compatible {
92 6     6   18 my ( $self, $content ) = @_;
93 6 100       19 if ( defined( my $start = $self->{_range_start} ) ) {
94 3         26 foreach my $re (
95             qr{ \A [[:upper:]] \z }smx,
96             qr{ \A [[:lower:]] \z }smx,
97             qr{ \A [0-9] \z }smx,
98             qr{ \A \\N \{ .* \} }smx,
99             ) {
100 3 50       57 $start =~ $re
101             or next;
102 3         38 return $content =~ $re;
103             }
104 0         0 return;
105             } else {
106 3         10 $self->{_range_start} = $content;
107 3         29 return 1;
108             }
109             }
110              
111             1;
112              
113             __END__