Regexp/Parser/JavaScript.pm

package Regexp::Parser::JavaScript;
use strict;
use warnings;

use Regexp::Parser::Perl58;
use Regexp::Parser qw(:original :RPe);
push our @ISA, 'Regexp::Parser::Perl58';

use constant RPJSe_OCTESC => 80130, 'Octal escape is obsolete';

my $IdentifierStart = qr/[
                          ## UnicodeLetter
                          \p{Lu}\p{Ll}\p{Lt}\p{Lm}\p{Lo}\p{Nl}

                          $ _ 
                         ]/x;

sub init ($) {
  my $self = shift;
  $self->SUPER::init;

  $self->{enum_to_level}->{[RPe_BADESC]->[0]} = 'm';
  $self->{enum_to_level}->{[RPe_BGROUP]->[0]} = 'm';
  $self->{enum_to_level}->{[RPJSe_OCTESC]->[0]} = 'm';
  $self->{enum_to_level}->{[RPe_FRANGE]->[0]} = 'm';

  $self->del_handler (qw/
                         \a \e \A \C \G \N \P \p \X \Z \z
                         (?# (?$ (?@ (?< (?> (?{ (?? (?p (?(
                        /);

  $self->add_handler('\v' => sub {
    my ($S, $cc) = @_;
    return $S->force_object(anyof_char => "\x0B", '\v') if $cc;
    return $S->object(exact => "\x0B" => '\v');
  });

  $self->add_handler('\n' => sub {
    my ($S, $cc) = @_;
    return $S->force_object(anyof_char => "\x0A", '\n') if $cc;
    return $S->object(exact => "\x0A" => '\n');
  });

  $self->add_handler('\r' => sub {
    my ($S, $cc) = @_;
    return $S->force_object(anyof_char => "\x0D", '\r') if $cc;
    return $S->object(exact => "\x0D" => '\r');
  });

  # backslash
  $self->add_handler('\\' => sub {
    my ($S, $cc) = @_;
    my $c = '\\';

    if (${&Rx} =~ m{ \G (.) }xgcs) {
      $c .= (my $n = $1);

      return $S->$c($cc) if $S->can($c);

      my $family = $cc ? 'anyof_char' : 'exact';

      if ($n =~ /\d/) {
        ## See <http://suika.fam.cx/%7Ewakaba/wiki/sw/n/%E5%85%AB%E9%80%B2%E3%82%A8%E3%82%B9%E3%82%B1%E3%83%BC%E3%83%97>.

        if ($n =~ /^[0-3]/ and ${&Rx} =~ m{ \G ([0-7]{1,2}) }xgc) {
          $n .= $1;
        }
        elsif ($n =~ /^[4-7]/ and ${&Rx} =~ m{ \G ([0-7]) }xgc) {
          $n .= $1;
        }

        # outside of char class, \nnn might be backref
        if (!&SIZE_ONLY and !$cc and $n !~ /^0/) {
          unless ($n > $S->{maxpar}) {
            return $S->object(ref => $n, "\\$n");
          }
        }
        if ($n =~ /^[89]/) {
          $S->warn(RPe_BGROUP);
          return $S->object($family => chr 0x30 + $n,
                            sprintf("\\x%02x", 0x30 + $n));
        }

        if ($n eq '0') {
          #
        } elsif ($n =~ /^0/ or $cc) {
          $S->warn(RPJSe_OCTESC);
        } elsif ($n > $S->{maxpar}) {
          $S->warn(RPe_BGROUP);
        }
        return $S->object($family => chr oct $n, sprintf("\\%03s", $n));
      }

      $S->warn(RPe_BADESC, $c = $n, "") if $n =~ /$IdentifierStart/o;

      return $S->object($family => $n, $c);
    }

    $S->error(RPe_ESLASH);
  });

  # control character
  $self->add_handler('\c' => sub {
    my ($S, $cc) = @_;
    ## See <http://suika.fam.cx/%7Ewakaba/wiki/sw/n/%5Cc>.
    if (${&Rx} =~ m{ \G ([A-Za-z]) }xgc) {
      my $c = $1;
      $c =~ tr/a-z/A-Z/;
      return $S->force_object(anyof_char => chr(64 ^ ord $c), "\\c$c") if $cc;
      return $S->object(exact => chr(64 ^ ord $c), "\\c$c");
    } else {
      my $c = 'c';
      $S->warn(RPe_BADESC, $c, "");
      return $S->object(($cc ? 'anyof_char' : 'exact') => $c, $c);
    }
  });

  # hex character
  $self->add_handler('\x' => sub {
    my ($S, $cc) = @_;

    my $num;
    if (${&Rx} =~ m{ \G ( [0-9A-Fa-f]{2} ) }sxgc) {
      $num = hex $1;
    } else {
      $num = ord 'x';
      $S->warn(RPe_BADESC, 'x', "");
    }

    my $rep = sprintf("\\x%02X", $num);
    return $S->force_object(anyof_char => chr $num, $rep) if $cc;
    return $S->object(exact => chr $num, $rep);
  });

  # \u
  $self->add_handler('\u' => sub {
    my ($S, $cc) = @_;

    my $num;
    if (${&Rx} =~ m{ \G ( [0-9A-Fa-f]{4} ) }sxgc) {
      $num = hex $1;
    } else {
      $num = ord 'u';
      $S->warn(RPe_BADESC, 'u', "");
    }
    
    my $rep = sprintf("\\u%04X", $num);
    return $S->force_object(anyof_char => chr $num, $rep) if $cc;
    return $S->object(exact => chr $num, $rep);
  });

  # start of char class range (or maybe just char)
  $self->add_handler('cc' => sub {
    my ($S) = @_;
    return if ${&Rx} =~ m{ \G (?= ] | \z ) }xgc;
    push @{ $S->{next} }, qw< cc >;
    my ($lhs, $rhs, $before_range);
    my $ret = \$lhs;

    {
      if (${&Rx} =~ m{ \G ( \\ ) }xgcs) {
        my $c = $1;
        $$ret = $S->$c(1);
      }
      elsif (${&Rx} =~ m{ \G (.) }xgcs) {
        $$ret = $S->force_object(anyof_char => $1);
      }

      if ($ret == \$lhs) {
        if (${&Rx} =~ m{ \G (?= - ) }xgc) {
          if ($lhs->visual =~ /^\\[dDsSwW]/) {
            $S->warn(RPe_FRANGE, $lhs->visual, "");
            $ret = $lhs;
            last;
          }
          $before_range = &RxPOS++;
          $ret = \$rhs;
          redo;
        }
        $ret = $lhs;
      }
      elsif ($ret == \$rhs) {
        if ($rhs->visual =~ /^\\[dDsSwW]/) {
          $S->warn(RPe_FRANGE, $lhs->visual, $rhs->visual);
          &RxPOS = $before_range;
          $ret = $lhs;
        }
        elsif ($lhs->data gt $rhs->data) { ## ->visual in the original code.
          $S->error(RPe_IRANGE, $lhs->visual, $rhs->visual);
        }
        else {
          $ret = $S->object(anyof_range => $lhs, $rhs);
        }
      }
    }
    
    return if &SIZE_ONLY;
    return $ret;
  });

  # char class ] at beginning
  $self->add_handler('cc]' => sub {
    my ($S) = @_;
    return unless ${&Rx} =~ m{ \G ] }xgc;
    pop @{ $S->{next} }; # cc
    pop @{ $S->{next} }; # cce]
    return $S->object(anyof_close => "]");
  });

  # some kind of assertion...
  $self->add_handler('(?' => sub {
    my ($S) = @_;
    my $c = '(?';

    if (${&Rx} =~ m{ \G (.) }xgcs) {
      my $n = "$c$1";
      return $S->$n if $S->can($n);
      &RxPOS--;
    }
    else {
      $S->error(RPe_SEQINC);
    }

    my $old = &RxPOS;

    if (${&Rx} =~ m{ \G : }xgc) {
      push @{ $S->{flags} }, &Rf;
      push @{ $S->{next} }, qw< c) atom >;
      return $S->object('group', 0, 0);
    }

    &RxPOS++;
    $S->error(RPe_NOTREC, 0, substr(${&Rx}, $old));
  });

} # init

1;
1	package Regexp::Parser::JavaScript;
2	use strict;
3	use warnings;
4
5	use Regexp::Parser::Perl58;
6	use Regexp::Parser qw(:original :RPe);
7	push our @ISA, 'Regexp::Parser::Perl58';
8
9	use constant RPJSe_OCTESC => 80130, 'Octal escape is obsolete';
10
11	my $IdentifierStart = qr/[
12	## UnicodeLetter
13	\p{Lu}\p{Ll}\p{Lt}\p{Lm}\p{Lo}\p{Nl}
14
15	$ _
16	]/x;
17
18	sub init ($) {
19	my $self = shift;
20	$self->SUPER::init;
21
22	$self->{enum_to_level}->{[RPe_BADESC]->[0]} = 'm';
23	$self->{enum_to_level}->{[RPe_BGROUP]->[0]} = 'm';
24	$self->{enum_to_level}->{[RPJSe_OCTESC]->[0]} = 'm';
25	$self->{enum_to_level}->{[RPe_FRANGE]->[0]} = 'm';
26
27	$self->del_handler (qw/
28	\a \e \A \C \G \N \P \p \X \Z \z
29	(?# (?$ (?@ (?< (?> (?{ (?? (?p (?(
30	/);
31
32	$self->add_handler('\v' => sub {
33	my ($S, $cc) = @_;
34	return $S->force_object(anyof_char => "\x0B", '\v') if $cc;
35	return $S->object(exact => "\x0B" => '\v');
36	});
37
38	$self->add_handler('\n' => sub {
39	my ($S, $cc) = @_;
40	return $S->force_object(anyof_char => "\x0A", '\n') if $cc;
41	return $S->object(exact => "\x0A" => '\n');
42	});
43
44	$self->add_handler('\r' => sub {
45	my ($S, $cc) = @_;
46	return $S->force_object(anyof_char => "\x0D", '\r') if $cc;
47	return $S->object(exact => "\x0D" => '\r');
48	});
49
50	# backslash
51	$self->add_handler('\\' => sub {
52	my ($S, $cc) = @_;
53	my $c = '\\';
54
55	if (${&Rx} =~ m{ \G (.) }xgcs) {
56	$c .= (my $n = $1);
57
58	return $S->$c($cc) if $S->can($c);
59
60	my $family = $cc ? 'anyof_char' : 'exact';
61
62	if ($n =~ /\d/) {
63	## See <http://suika.fam.cx/%7Ewakaba/wiki/sw/n/%E5%85%AB%E9%80%B2%E3%82%A8%E3%82%B9%E3%82%B1%E3%83%BC%E3%83%97>.
64
65	if ($n =~ /^[0-3]/ and ${&Rx} =~ m{ \G ([0-7]{1,2}) }xgc) {
66	$n .= $1;
67	}
68	elsif ($n =~ /^[4-7]/ and ${&Rx} =~ m{ \G ([0-7]) }xgc) {
69	$n .= $1;
70	}
71
72	# outside of char class, \nnn might be backref
73	if (!&SIZE_ONLY and !$cc and $n !~ /^0/) {
74	unless ($n > $S->{maxpar}) {
75	return $S->object(ref => $n, "\\$n");
76	}
77	}
78	if ($n =~ /^[89]/) {
79	$S->warn(RPe_BGROUP);
80	return $S->object($family => chr 0x30 + $n,
81	sprintf("\\x%02x", 0x30 + $n));
82	}
83
84	if ($n eq '0') {
85	#
86	} elsif ($n =~ /^0/ or $cc) {
87	$S->warn(RPJSe_OCTESC);
88	} elsif ($n > $S->{maxpar}) {
89	$S->warn(RPe_BGROUP);
90	}
91	return $S->object($family => chr oct $n, sprintf("\\%03s", $n));
92	}
93
94	$S->warn(RPe_BADESC, $c = $n, "") if $n =~ /$IdentifierStart/o;
95
96	return $S->object($family => $n, $c);
97	}
98
99	$S->error(RPe_ESLASH);
100	});
101
102	# control character
103	$self->add_handler('\c' => sub {
104	my ($S, $cc) = @_;
105	## See <http://suika.fam.cx/%7Ewakaba/wiki/sw/n/%5Cc>.
106	if (${&Rx} =~ m{ \G ([A-Za-z]) }xgc) {
107	my $c = $1;
108	$c =~ tr/a-z/A-Z/;
109	return $S->force_object(anyof_char => chr(64 ^ ord $c), "\\c$c") if $cc;
110	return $S->object(exact => chr(64 ^ ord $c), "\\c$c");
111	} else {
112	my $c = 'c';
113	$S->warn(RPe_BADESC, $c, "");
114	return $S->object(($cc ? 'anyof_char' : 'exact') => $c, $c);
115	}
116	});
117
118	# hex character
119	$self->add_handler('\x' => sub {
120	my ($S, $cc) = @_;
121
122	my $num;
123	if (${&Rx} =~ m{ \G ( [0-9A-Fa-f]{2} ) }sxgc) {
124	$num = hex $1;
125	} else {
126	$num = ord 'x';
127	$S->warn(RPe_BADESC, 'x', "");
128	}
129
130	my $rep = sprintf("\\x%02X", $num);
131	return $S->force_object(anyof_char => chr $num, $rep) if $cc;
132	return $S->object(exact => chr $num, $rep);
133	});
134
135	# \u
136	$self->add_handler('\u' => sub {
137	my ($S, $cc) = @_;
138
139	my $num;
140	if (${&Rx} =~ m{ \G ( [0-9A-Fa-f]{4} ) }sxgc) {
141	$num = hex $1;
142	} else {
143	$num = ord 'u';
144	$S->warn(RPe_BADESC, 'u', "");
145	}
146
147	my $rep = sprintf("\\u%04X", $num);
148	return $S->force_object(anyof_char => chr $num, $rep) if $cc;
149	return $S->object(exact => chr $num, $rep);
150	});
151
152	# start of char class range (or maybe just char)
153	$self->add_handler('cc' => sub {
154	my ($S) = @_;
155	return if ${&Rx} =~ m{ \G (?= ] \| \z ) }xgc;
156	push @{ $S->{next} }, qw< cc >;
157	my ($lhs, $rhs, $before_range);
158	my $ret = \$lhs;
159
160	{
161	if (${&Rx} =~ m{ \G ( \\ ) }xgcs) {
162	my $c = $1;
163	$$ret = $S->$c(1);
164	}
165	elsif (${&Rx} =~ m{ \G (.) }xgcs) {
166	$$ret = $S->force_object(anyof_char => $1);
167	}
168
169	if ($ret == \$lhs) {
170	if (${&Rx} =~ m{ \G (?= - ) }xgc) {
171	if ($lhs->visual =~ /^\\[dDsSwW]/) {
172	$S->warn(RPe_FRANGE, $lhs->visual, "");
173	$ret = $lhs;
174	last;
175	}
176	$before_range = &RxPOS++;
177	$ret = \$rhs;
178	redo;
179	}
180	$ret = $lhs;
181	}
182	elsif ($ret == \$rhs) {
183	if ($rhs->visual =~ /^\\[dDsSwW]/) {
184	$S->warn(RPe_FRANGE, $lhs->visual, $rhs->visual);
185	&RxPOS = $before_range;
186	$ret = $lhs;
187	}
188	elsif ($lhs->data gt $rhs->data) { ## ->visual in the original code.
189	$S->error(RPe_IRANGE, $lhs->visual, $rhs->visual);
190	}
191	else {
192	$ret = $S->object(anyof_range => $lhs, $rhs);
193	}
194	}
195	}
196
197	return if &SIZE_ONLY;
198	return $ret;
199	});
200
201	# char class ] at beginning
202	$self->add_handler('cc]' => sub {
203	my ($S) = @_;
204	return unless ${&Rx} =~ m{ \G ] }xgc;
205	pop @{ $S->{next} }; # cc
206	pop @{ $S->{next} }; # cce]
207	return $S->object(anyof_close => "]");
208	});
209
210	# some kind of assertion...
211	$self->add_handler('(?' => sub {
212	my ($S) = @_;
213	my $c = '(?';
214
215	if (${&Rx} =~ m{ \G (.) }xgcs) {
216	my $n = "$c$1";
217	return $S->$n if $S->can($n);
218	&RxPOS--;
219	}
220	else {
221	$S->error(RPe_SEQINC);
222	}
223
224	my $old = &RxPOS;
225
226	if (${&Rx} =~ m{ \G : }xgc) {
227	push @{ $S->{flags} }, &Rf;
228	push @{ $S->{next} }, qw< c) atom >;
229	return $S->object('group', 0, 0);
230	}
231
232	&RxPOS++;
233	$S->error(RPe_NOTREC, 0, substr(${&Rx}, $old));
234	});
235
236	} # init
237
238	1;