Install arch-dependent files into $archlib.
[perl.git] / mad / P5re.pm
1 #!/usr/bin/perl
2
3 # Copyright (C) 2005, Larry Wall
4 # This software may be copied under the same terms as Perl.
5
6 package P5re;
7
8 use strict;
9 use warnings;
10
11 our @EXPORT_OK = qw(re re2xml qr2xml);
12
13 my $indent = 0;
14 my $in = "";
15 my $delim = 1;
16 my $debug = 0;
17 my $maxbrack;
18
19 our $extended;
20 our $insensitive;
21 our $singleline;
22 our $multiline;
23
24 my %xmlish = (
25         chr(0x00) => "STUPIDXML(#x00)",
26         chr(0x01) => "STUPIDXML(#x01)",
27         chr(0x02) => "STUPIDXML(#x02)",
28         chr(0x03) => "STUPIDXML(#x03)",
29         chr(0x04) => "STUPIDXML(#x04)",
30         chr(0x05) => "STUPIDXML(#x05)",
31         chr(0x06) => "STUPIDXML(#x06)",
32         chr(0x07) => "STUPIDXML(#x07)",
33         chr(0x08) => "STUPIDXML(#x08)",
34         chr(0x09) => "	",
35         chr(0x0a) => "
",
36         chr(0x0b) => "STUPIDXML(#x0b)",
37         chr(0x0c) => "STUPIDXML(#x0c)",
38         chr(0x0d) => "
",
39         chr(0x0e) => "STUPIDXML(#x0e)",
40         chr(0x0f) => "STUPIDXML(#x0f)",
41         chr(0x10) => "STUPIDXML(#x10)",
42         chr(0x11) => "STUPIDXML(#x11)",
43         chr(0x12) => "STUPIDXML(#x12)",
44         chr(0x13) => "STUPIDXML(#x13)",
45         chr(0x14) => "STUPIDXML(#x14)",
46         chr(0x15) => "STUPIDXML(#x15)",
47         chr(0x16) => "STUPIDXML(#x16)",
48         chr(0x17) => "STUPIDXML(#x17)",
49         chr(0x18) => "STUPIDXML(#x18)",
50         chr(0x19) => "STUPIDXML(#x19)",
51         chr(0x1a) => "STUPIDXML(#x1a)",
52         chr(0x1b) => "STUPIDXML(#x1b)",
53         chr(0x1c) => "STUPIDXML(#x1c)",
54         chr(0x1d) => "STUPIDXML(#x1d)",
55         chr(0x1e) => "STUPIDXML(#x1e)",
56         chr(0x1f) => "STUPIDXML(#x1f)",
57         chr(0x7f) => "STUPIDXML(#x7f)",
58         chr(0x80) => "STUPIDXML(#x80)",
59         chr(0x81) => "STUPIDXML(#x81)",
60         chr(0x82) => "STUPIDXML(#x82)",
61         chr(0x83) => "STUPIDXML(#x83)",
62         chr(0x84) => "STUPIDXML(#x84)",
63         chr(0x86) => "STUPIDXML(#x86)",
64         chr(0x87) => "STUPIDXML(#x87)",
65         chr(0x88) => "STUPIDXML(#x88)",
66         chr(0x89) => "STUPIDXML(#x89)",
67         chr(0x90) => "STUPIDXML(#x90)",
68         chr(0x91) => "STUPIDXML(#x91)",
69         chr(0x92) => "STUPIDXML(#x92)",
70         chr(0x93) => "STUPIDXML(#x93)",
71         chr(0x94) => "STUPIDXML(#x94)",
72         chr(0x95) => "STUPIDXML(#x95)",
73         chr(0x96) => "STUPIDXML(#x96)",
74         chr(0x97) => "STUPIDXML(#x97)",
75         chr(0x98) => "STUPIDXML(#x98)",
76         chr(0x99) => "STUPIDXML(#x99)",
77         chr(0x9a) => "STUPIDXML(#x9a)",
78         chr(0x9b) => "STUPIDXML(#x9b)",
79         chr(0x9c) => "STUPIDXML(#x9c)",
80         chr(0x9d) => "STUPIDXML(#x9d)",
81         chr(0x9e) => "STUPIDXML(#x9e)",
82         chr(0x9f) => "STUPIDXML(#x9f)",
83         '<'       => "&lt;",
84         '>'       => "&gt;",
85         '&'       => "&amp;",
86         '"'       => "&#34;",           # XML idiocy
87 );
88
89 sub xmlquote {
90     my $text = shift;
91     $text =~ s/(.)/$xmlish{$1} || $1/seg;
92     return $text;
93 }
94
95 sub text {
96     my $self = shift;
97     return xmlquote($self->{text});
98 }
99
100 sub rep {
101     my $self = shift;
102     return xmlquote($self->{rep});
103 }
104
105 sub xmlkids {
106     my $self = shift;
107     my $array = $self->{Kids};
108     my $ret = "";
109     $indent += 2;
110     $in = ' ' x $indent;
111     foreach my $chunk (@$array) {
112         if (ref $chunk eq "ARRAY") {
113             die;
114         }
115         elsif (ref $chunk) {
116             $ret .= $chunk->xml();
117         }
118         else {
119             warn $chunk;
120         }
121     }
122     $indent -= 2;
123     $in = ' ' x $indent;
124     return $ret;
125 };
126
127 package P5re::RE; our @ISA = 'P5re';
128
129 sub xml {
130     my $self = shift;
131     my %flags = @_;
132     if ($flags{indent}) {
133         $indent = delete $flags{indent} || 0;
134         $in = ' ' x $indent;
135     }
136
137     my $kind = $self->{kind};
138
139     my $first = $self->{Kids}[0];
140     if ($first and ref $first eq 'P5re::Mod') {
141         for my $c (qw(i m s x)) {
142             next unless defined $first->{$c};
143             $self->{$c} = $first->{$c};
144             delete $first->{$c};
145         }
146     }
147
148     my $modifiers = "";
149     foreach my $k (sort keys %$self) {
150         next if $k eq 'kind' or $k eq "Kids";
151         my $v = $self->{$k};
152         $k =~ s/^[A-Z]//;
153         $modifiers .= " $k=\"$v\"";
154     }
155     my $text = "$in<$kind$modifiers>\n";
156     $text .= $self->xmlkids();
157     $text .= "$in</$kind>\n";
158     return $text;
159 }
160
161 package P5re::Alt; our @ISA = 'P5re';
162
163 sub xml {
164     my $self = shift;
165     my $text = "$in<alt>\n";
166     $text .= $self->xmlkids();
167     $text .= "$in</alt>\n";
168     return $text;
169 }
170
171 #package P5re::Atom; our @ISA = 'P5re';
172 #
173 #sub xml {
174 #    my $self = shift;
175 #    my $text = "$in<atom>\n";
176 #    $text .= $self->xmlkids();
177 #    $text .= "$in</atom>\n";
178 #    return $text;
179 #}
180
181 package P5re::Quant; our @ISA = 'P5re';
182
183 sub xml {
184     my $self = shift;
185     my $q = $self->{rep};
186     my $min = $self->{min};
187     my $max = $self->{max};
188     my $greedy = $self->{greedy};
189     my $text = "$in<quant rep=\"$q\" min=\"$min\" max=\"$max\" greedy=\"$greedy\">\n";
190     $text .= $self->xmlkids();
191     $text .= "$in</quant>\n";
192     return $text;
193 }
194
195 package P5re::White; our @ISA = 'P5re';
196
197 sub xml {
198     my $self = shift;
199     return "$in<white text=\"" . $self->text() . "\" />\n";
200 }
201
202 package P5re::Char; our @ISA = 'P5re';
203
204 sub xml {
205     my $self = shift;
206     return "$in<char text=\"" . $self->text() . "\" />\n";
207 }
208
209 package P5re::Comment; our @ISA = 'P5re';
210
211 sub xml {
212     my $self = shift;
213     return "$in<comment rep=\"" . $self->rep() . "\" />\n";
214 }
215
216 package P5re::Mod; our @ISA = 'P5re';
217
218 sub xml {
219     my $self = shift;
220     my $modifiers = "";
221     foreach my $k (sort keys %$self) {
222         next if $k eq 'kind' or $k eq "Kids";
223         my $v = $self->{$k};
224         $k =~ s/^[A-Z]//;
225         $modifiers .= " $k=\"$v\"";
226     }
227     return "$in<mod$modifiers />\n";
228 }
229
230 package P5re::Meta; our @ISA = 'P5re';
231
232 sub xml {
233     my $self = shift;
234     my $sem = "";
235     if ($self->{sem}) {
236         $sem = 'sem="' . $self->{sem} . '" '
237     }
238     return "$in<meta rep=\"" . $self->rep() . "\" $sem/>\n";
239 }
240
241 package P5re::Back; our @ISA = 'P5re';
242
243 sub xml {
244     my $self = shift;
245     return "$in<backref to=\"" . P5re::xmlquote($self->{to}) . "\"/>\n";
246 }
247
248 package P5re::Var; our @ISA = 'P5re';
249
250 sub xml {
251     my $self = shift;
252     return "$in<var name=\"" . $self->{name} . "\" />\n";
253 }
254
255 package P5re::Closure; our @ISA = 'P5re';
256
257 sub xml {
258     my $self = shift;
259     return "$in<closure rep=\"" . P5re::xmlquote($self->{rep}) . "\" />\n";
260 }
261
262 package P5re::CClass; our @ISA = 'P5re';
263
264 sub xml {
265     my $self = shift;
266     my $neg = $self->{neg} ? "negated" : "normal";
267     my $text = "$in<cclass match=\"$neg\">\n";
268     $text .= $self->xmlkids();
269     $text .= "$in</cclass>\n";
270     return $text;
271 }
272
273 package P5re::Range; our @ISA = 'P5re';
274
275 sub xml {
276     my $self = shift;
277     my $text = "$in<range>\n";
278     $text .= $self->xmlkids();
279     $text .= "$in</range>\n";
280     return $text;
281 }
282
283 package P5re;
284
285 unless (caller) {
286     while (<>) {
287         chomp;
288         print qr2xml($_);
289         print "#######################################\n";
290     }
291 }
292
293 sub qrparse {
294     my $qr = shift;
295     my $mod;
296     if ($qr =~ /^s/) {
297         $qr =~ s/^(?:\w*)(\W)((?:\\.|.)*?)\1(.*)\1(\w*)$/$2/;
298         $mod = $4;
299     }
300     else {
301         $qr =~ s/^(?:\w*)(\W)(.*)\1(\w*)$/$2/;
302         $mod = $3;
303     }
304     substr($qr,0,0) = "(?$mod)" if defined $mod and $mod ne "";
305     return parse($qr,@_);
306 }
307
308 sub qr2xml {
309     return qrparse(@_)->xml();
310 }
311
312 sub re2xml {
313     my $re = shift;
314     return parse($re,@_)->xml();
315 }
316
317 sub parse {
318     local($_) = shift;
319     my %flags = @_;
320     $maxbrack = 0;
321     $indent = delete $flags{indent} || 0;
322     $in = ' ' x $indent;
323     warn "$_\n" if $debug;
324     my $re = re('re');
325     @$re{keys %flags} = values %flags;
326     return $re;
327 }
328
329 sub re {
330     my $kind = shift;
331
332     my $oldextended = $extended;
333     my $oldinsensitive = $insensitive;
334     my $oldmultiline = $multiline;
335     my $oldsingleline = $singleline;
336
337     local $extended = $extended;
338     local $insensitive = $insensitive;
339     local $multiline = $multiline;
340     local $singleline = $singleline;
341
342     my $first = alt();
343
344     my $re;
345     if (not /^\|/) {
346         $first->{kind} = $kind;
347         $re = bless $first, "P5re::RE";  # rebless to remove single alt
348     }
349     else {
350         my @alts = ($first);
351
352         while (s/^\|//) {
353             push(@alts, alt());
354         }
355         $re = bless { Kids => [@alts], kind => $kind }, "P5re::RE";     
356     }
357
358     $re->{x} = $oldextended || 0;
359     $re->{i} = $oldinsensitive || 0;
360     $re->{m} = $oldmultiline || 0;
361     $re->{s} = $oldsingleline || 0;
362     return $re;
363 }
364
365 sub alt {
366     my @quants;
367
368     my $quant;
369     while ($quant = quant()) {
370         if (@quants and
371             ref $quant eq ref $quants[-1] and
372             exists $quants[-1]{text} and
373             exists $quant->{text} )
374         {
375             $quants[-1]{text} .= $quant->{text};
376         }
377         else {
378             push(@quants, $quant);
379         }
380     }
381     return bless { Kids => [@quants] }, "P5re::Alt";    
382 }
383
384 sub quant {
385     my $atom = atom();
386     return 0 unless $atom;
387 #    $atom = bless { Kids => [$atom] }, "P5re::Atom";   
388     if (s/^(([*+?])(\??)|\{(\d+)(?:(,)(\d*))?\}(\??))//) {
389         my $min = 0;
390         my $max = "Inf";
391         my $greed = 1;
392         if ($2) {
393             if ($2 eq '+') {
394                 $min = 1;
395             }
396             elsif ($2 eq '?') {
397                 $max = 1;
398             }
399             $greed = 0 if $3;
400         }
401         elsif (defined $4) {
402             $min = $4;
403             if ($5) {
404                 $max = $6 if $6;
405             }
406             else {
407                 $max = $min;
408             }
409             $greed = 0 if $7;
410         }
411         $greed = "na" if $min == $max;
412         return bless { Kids => [$atom],
413                     rep => $1,
414                     min => $min,
415                     max => $max,
416                     greedy => $greed
417                 }, "P5re::Quant";       
418     }
419     return $atom;
420 }
421
422 sub atom {
423     my $re;
424     if ($_ eq "") { return 0 }
425     if (/^[)|]/) { return 0 }
426
427     # whitespace is special because we don't know if /x is in effect
428     if ($extended) {
429         if (s/^(?=\s|#)(\s*(?:#.*)?)//) { return bless { text => $1 }, "P5re::White"; }
430     }
431
432     # all the parenthesized forms
433     if (s/^\(//) {
434         if (s/^\?://) {
435             $re = re('bracket');
436         }
437         elsif (s/^(\?#.*?)\)/)/) {
438             $re = bless { rep => "($1)" }, "P5re::Comment";     
439         }
440         elsif (s/^\?=//) {
441             $re = re('lookahead');
442         }
443         elsif (s/^\?!//) {
444             $re = re('neglookahead');
445         }
446         elsif (s/^\?<=//) {
447             $re = re('lookbehind');
448         }
449         elsif (s/^\?<!//) {
450             $re = re('neglookbehind');
451         }
452         elsif (s/^\?>//) {
453             $re = re('nobacktrack');
454         }
455         elsif (s/^(\?\??\{.*?\})\)/)/) {
456             $re = bless { rep => "($1)" }, "P5re::Closure";     
457         }
458         elsif (s/^(\?\(\d+\))//) {
459             my $mods = $1;
460             $re = re('conditional');
461             $re->{Arep} = "$mods";
462         }
463         elsif (s/^\?(?=\(\?)//) {
464             my $mods = $1;
465             my $cond = atom();
466             $re = re('conditional');
467             unshift(@{$re->{Kids}}, $cond);
468         }
469         elsif (s/^(\?[-\w]+)://) {
470             my $mods = $1;
471             local $extended = $extended;
472             local $insensitive = $insensitive;
473             local $multiline = $multiline;
474             local $singleline = $singleline;
475             setmods($mods);
476             $re = re('bracket');
477             $re->{Arep} = "($mods)";
478             $re->{x} = $extended || 0;
479             $re->{i} = $insensitive || 0;
480             $re->{m} = $multiline || 0;
481             $re->{s} = $singleline || 0;
482         }
483         elsif (s/^(\?[-\w]+)//) {
484             my $mods = $1;
485             $re = bless { Arep => "($mods)" }, "P5re::Mod";     
486             setmods($mods);
487             $re->{x} = $extended || 0;
488             $re->{i} = $insensitive || 0;
489             $re->{m} = $multiline || 0;
490             $re->{s} = $singleline || 0;
491         }
492         elsif (s/^\?//) {
493             $re = re('UNRECOGNIZED');
494         }
495         else {
496             my $brack = ++$maxbrack;
497             $re = re('capture');
498             $re->{Ato} = $brack;
499         }
500
501         if (not s/^\)//) { warn "Expected right paren at: '$_'" }
502         return $re;
503     }
504
505     # special meta
506     if (s/^\.//) {
507         my $s = $singleline ? '.' : '\N';
508         return bless { rep => '.', sem => $s }, "P5re::Meta";
509     }
510     if (s/^\^//) {
511         my $s = $multiline ? '^^' : '^';
512         return bless { rep => '^', sem => $s }, "P5re::Meta";
513     }
514     if (s/^\$(?:$|(?=[|)]))//) {
515         my $s = $multiline ? '$$' : '$';
516         return bless { rep => '$', sem => $s }, "P5re::Meta";
517     }
518     if (s/^([\$\@](\w+|.))//) {         # XXX need to handle subscripts here
519         return bless { name => $1 }, "P5re::Var";
520     }
521
522     # character classes
523     if (s/^\[//) {
524         my $re = cclass();
525         if (not s/^\]//) { warn "Expected right bracket at: '$_'" }
526         return $re;
527     }
528
529     # backwhacks
530     if (/^\\([1-9]\d*)/ and $1 <= $maxbrack) {
531         my $to = $1;
532         onechar();
533         return bless { to => $to }, "P5re::Back";
534     }
535
536     # backwhacks
537     if (/^\\(?=\w)/) {
538         return bless { rep => onechar() }, "P5re::Meta";
539     }
540
541     # backwhacks
542     if (s/^\\(.)//) {
543         return bless { text => $1 }, "P5re::Char";
544     }
545
546     # optimization, would happen anyway
547     if (s/^(\w+)//) { return bless { text => $1 }, "P5re::Char"; }
548
549     # random character
550     if (s/^(.)//) { return bless { text => $1 }, "P5re::Char"; }
551 }
552
553 sub cclass {
554     my @cclass;
555     my $cclass = "";
556     my $neg = 0;
557     if (s/^\^//) { $neg = 1 }
558     if (s/^([\]\-])//) { $cclass .= $1 }
559
560     while ($_ ne "" and not /^\]/) {
561         # backwhacks
562         if (/^\\(?=.)|.-/) {
563             my $o1 = onecharobj();
564             if ($cclass ne "") {
565                 push @cclass, bless { text => $cclass }, "P5re::Char";
566                 $cclass = "";
567             }
568
569             if (s/^-(?=[^]])//) {
570                 my $o2 = onecharobj();
571                 push @cclass, bless { Kids => [$o1, $o2] }, "P5re::Range";
572             }
573             else {
574                 push @cclass, $o1;
575             }
576         }
577         elsif (s/^(\[([:=.])\^?\w*\2\])//) {
578             if ($cclass ne "") {
579                 push @cclass, bless { text => $cclass }, "P5re::Char";
580                 $cclass = "";
581             }
582             push @cclass, bless { rep => $1 }, "P5re::Meta";
583         }
584         else {
585             $cclass .= onechar();
586         }
587     }
588
589     if ($cclass ne "") {
590         push @cclass, bless { text => $cclass }, "P5re::Char";
591     }
592     return bless { Kids => [@cclass], neg => $neg }, "P5re::CClass";
593 }
594
595 sub onecharobj {
596     my $ch = onechar();
597     if ($ch =~ /^\\/) {
598         $ch = bless { rep => $ch }, "P5re::Meta";
599     }
600     else {
601         $ch = bless { text => $ch }, "P5re::Char";
602     }
603 }
604
605 sub onechar {
606     die "Oops, short cclass" unless s/^(.)//;
607     my $ch = $1;
608     if ($ch eq '\\') {
609         if (s/^([rntf]|[0-7]{1,4})//) { $ch .= $1 }
610         elsif (s/^(x[0-9a-fA-f]{1,2})//) { $ch .= $1 }
611         elsif (s/^(x\{[0-9a-fA-f]+\})//) { $ch .= $1 }
612         elsif (s/^([NpP]\{.*?\})//) { $ch .= $1 }
613         elsif (s/^([cpP].)//) { $ch .= $1 }
614         elsif (s/^(.)//) { $ch .= $1 }
615         else {
616             die "Oops, short backwhack";
617         }
618     }
619     return $ch;
620 }
621
622 sub setmods {
623     my $mods = shift;
624     if ($mods =~ /\-.*x/) {
625         $extended = 0;
626     }
627     elsif ($mods =~ /x/) {
628         $extended = 1;
629     }
630     if ($mods =~ /\-.*i/) {
631         $insensitive = 0;
632     }
633     elsif ($mods =~ /i/) {
634         $insensitive = 1;
635     }
636     if ($mods =~ /\-.*m/) {
637         $multiline = 0;
638     }
639     elsif ($mods =~ /m/) {
640         $multiline = 1;
641     }
642     if ($mods =~ /\-.*s/) {
643         $singleline = 0;
644     }
645     elsif ($mods =~ /s/) {
646         $singleline = 1;
647     }
648 }
649
650 1;