mad/P5RE.pm

   1 #!/usr/bin/perl
   2
   3 use strict;
   4 use warnings;
   5
   6 my $depth = 0;
   7 my $in = "";
   8 my $delim = 1;
   9
  10 package P5RE;
  11
  12 our $extended;
  13 our $insensitive;
  14 our $singleline;
  15 our $multiline;
  16
  17 my %xmlish = (
  18         chr(0x00) => "STUPIDXML(#x00)",
  19         chr(0x01) => "STUPIDXML(#x01)",
  20         chr(0x02) => "STUPIDXML(#x02)",
  21         chr(0x03) => "STUPIDXML(#x03)",
  22         chr(0x04) => "STUPIDXML(#x04)",
  23         chr(0x05) => "STUPIDXML(#x05)",
  24         chr(0x06) => "STUPIDXML(#x06)",
  25         chr(0x07) => "STUPIDXML(#x07)",
  26         chr(0x08) => "STUPIDXML(#x08)",
  27         chr(0x09) => "&#9;",
  28         chr(0x0a) => "&#10;",
  29         chr(0x0b) => "STUPIDXML(#x0b)",
  30         chr(0x0c) => "STUPIDXML(#x0c)",
  31         chr(0x0d) => "&#13;",
  32         chr(0x0e) => "STUPIDXML(#x0e)",
  33         chr(0x0f) => "STUPIDXML(#x0f)",
  34         chr(0x10) => "STUPIDXML(#x10)",
  35         chr(0x11) => "STUPIDXML(#x11)",
  36         chr(0x12) => "STUPIDXML(#x12)",
  37         chr(0x13) => "STUPIDXML(#x13)",
  38         chr(0x14) => "STUPIDXML(#x14)",
  39         chr(0x15) => "STUPIDXML(#x15)",
  40         chr(0x16) => "STUPIDXML(#x16)",
  41         chr(0x17) => "STUPIDXML(#x17)",
  42         chr(0x18) => "STUPIDXML(#x18)",
  43         chr(0x19) => "STUPIDXML(#x19)",
  44         chr(0x1a) => "STUPIDXML(#x1a)",
  45         chr(0x1b) => "STUPIDXML(#x1b)",
  46         chr(0x1c) => "STUPIDXML(#x1c)",
  47         chr(0x1d) => "STUPIDXML(#x1d)",
  48         chr(0x1e) => "STUPIDXML(#x1e)",
  49         chr(0x1f) => "STUPIDXML(#x1f)",
  50         chr(0x7f) => "STUPIDXML(#x7f)",
  51         chr(0x80) => "STUPIDXML(#x80)",
  52         chr(0x81) => "STUPIDXML(#x81)",
  53         chr(0x82) => "STUPIDXML(#x82)",
  54         chr(0x83) => "STUPIDXML(#x83)",
  55         chr(0x84) => "STUPIDXML(#x84)",
  56         chr(0x86) => "STUPIDXML(#x86)",
  57         chr(0x87) => "STUPIDXML(#x87)",
  58         chr(0x88) => "STUPIDXML(#x88)",
  59         chr(0x89) => "STUPIDXML(#x89)",
  60         chr(0x90) => "STUPIDXML(#x90)",
  61         chr(0x91) => "STUPIDXML(#x91)",
  62         chr(0x92) => "STUPIDXML(#x92)",
  63         chr(0x93) => "STUPIDXML(#x93)",
  64         chr(0x94) => "STUPIDXML(#x94)",
  65         chr(0x95) => "STUPIDXML(#x95)",
  66         chr(0x96) => "STUPIDXML(#x96)",
  67         chr(0x97) => "STUPIDXML(#x97)",
  68         chr(0x98) => "STUPIDXML(#x98)",
  69         chr(0x99) => "STUPIDXML(#x99)",
  70         chr(0x9a) => "STUPIDXML(#x9a)",
  71         chr(0x9b) => "STUPIDXML(#x9b)",
  72         chr(0x9c) => "STUPIDXML(#x9c)",
  73         chr(0x9d) => "STUPIDXML(#x9d)",
  74         chr(0x9e) => "STUPIDXML(#x9e)",
  75         chr(0x9f) => "STUPIDXML(#x9f)",
  76         '<'       => "&lt;",
  77         '>'       => "&gt;",
  78         '&'       => "&amp;",
  79         '"'       => "&#34;",           # XML idiocy
  80 );
  81
  82 sub xmlquote {
  83     my $text = shift;
  84     $text =~ s/(.)/$xmlish{$1} || $1/seg;
  85     return $text;
  86 }
  87
  88 sub text {
  89     my $self = shift;
  90     return xmlquote($self->{text});
  91 }
  92
  93 sub rep {
  94     my $self = shift;
  95     return xmlquote($self->{rep});
  96 }
  97
  98 sub xmlkids {
  99     my $self = shift;
 100     my $array = $self->{Kids};
 101     my $ret = "";
 102     $depth++;
 103     $in = ' ' x ($depth * 2);
 104     foreach my $chunk (@$array) {
 105         if (ref $chunk eq "ARRAY") {
 106             die;
 107         }
 108         elsif (ref $chunk) {
 109             $ret .= $chunk->xml();
 110         }
 111         else {
 112             warn $chunk;
 113         }
 114     }
 115     $depth--;
 116     $in = ' ' x ($depth * 2);
 117     return $ret;
 118 };
 119
 120 package P5RE::RE; BEGIN { our @ISA = 'P5RE'; }
 121
 122 sub xml {
 123     my $self = shift;
 124     my $kind = $self->{kind};
 125     my $modifiers = $self->{modifiers} || "";
 126     if ($modifiers) {
 127         $modifiers = " modifiers=\"$modifiers\"";
 128     }
 129     my $text = "$in<$kind$modifiers>\n";
 130     $text .= $self->xmlkids();
 131     $text .= "$in</$kind>\n";
 132     return $text;
 133 }
 134
 135 package P5RE::Alt; our @ISA = 'P5RE';
 136
 137 sub xml {
 138     my $self = shift;
 139     my $text = "$in<alt>\n";
 140     $text .= $self->xmlkids();
 141     $text .= "$in</alt>\n";
 142     return $text;
 143 }
 144
 145 #package P5RE::Atom; our @ISA = 'P5RE';
 146 #
 147 #sub xml {
 148 #    my $self = shift;
 149 #    my $text = "$in<atom>\n";
 150 #    $text .= $self->xmlkids();
 151 #    $text .= "$in</atom>\n";
 152 #    return $text;
 153 #}
 154
 155 package P5RE::Quant; our @ISA = 'P5RE';
 156
 157 sub xml {
 158     my $self = shift;
 159     my $q = $self->{type};
 160     my $text = "$in<quant type=\"$q\">\n";
 161     $text .= $self->xmlkids();
 162     $text .= "$in</quant>\n";
 163     return $text;
 164 }
 165
 166 package P5RE::White; our @ISA = 'P5RE';
 167
 168 sub xml {
 169     my $self = shift;
 170     return "$in<white text=\"" . $self->text() . "\" />\n";
 171 }
 172
 173 package P5RE::Char; our @ISA = 'P5RE';
 174
 175 sub xml {
 176     my $self = shift;
 177     return "$in<char text=\"" . $self->text() . "\" />\n";
 178 }
 179
 180 package P5RE::Comment; our @ISA = 'P5RE';
 181
 182 sub xml {
 183     my $self = shift;
 184     return "$in<comment rep=\"" . $self->rep() . "\" />\n";
 185 }
 186
 187 package P5RE::Mod; our @ISA = 'P5RE';
 188
 189 sub xml {
 190     my $self = shift;
 191     return "$in<mod modifiers=\"" . $self->{modifiers} . "\" />\n";
 192 }
 193
 194 package P5RE::Meta; our @ISA = 'P5RE';
 195
 196 sub xml {
 197     my $self = shift;
 198     my $sem = "";
 199     if ($self->{sem}) {
 200         $sem = 'sem="' . $self->{sem} . '" '
 201     }
 202     return "$in<meta rep=\"" . $self->rep() . "\" $sem/>\n";
 203 }
 204
 205 package P5RE::Var; our @ISA = 'P5RE';
 206
 207 sub xml {
 208     my $self = shift;
 209     return "$in<var name=\"" . $self->{name} . "\" />\n";
 210 }
 211
 212 package P5RE::Closure; our @ISA = 'P5RE';
 213
 214 sub xml {
 215     my $self = shift;
 216     return "$in<closure rep=\"" . $self->{rep} . "\" />\n";
 217 }
 218
 219 package P5RE::CClass; our @ISA = 'P5RE';
 220
 221 sub xml {
 222     my $self = shift;
 223     my $neg = $self->{neg} ? "negated" : "normal";
 224     my $text = "$in<cclass match=\"$neg\">\n";
 225     $text .= $self->xmlkids();
 226     $text .= "$in</cclass>\n";
 227     return $text;
 228 }
 229
 230 package P5RE::Range; our @ISA = 'P5RE';
 231
 232 sub xml {
 233     my $self = shift;
 234     my $text = "$in<range>\n";
 235     $text .= $self->xmlkids();
 236     $text .= "$in</range>\n";
 237     return $text;
 238 }
 239
 240 package P5RE;
 241
 242 sub re {
 243     my $kind = shift;
 244     my @alts;
 245
 246     push(@alts, alt());
 247
 248     while (s/^\|//) {
 249         push(@alts, alt());
 250     }
 251     return bless { Kids => [@alts], kind => $kind }, "P5RE::RE";
 252 }
 253
 254 sub alt {
 255     my @quants;
 256
 257     my $quant;
 258     local $extended = $extended;
 259     local $insensitive = $insensitive;
 260     local $multiline = $multiline;
 261     local $singleline = $singleline;
 262     while ($quant = quant()) {
 263         if (@quants and
 264             ref $quant eq ref $quants[-1] and
 265             exists $quants[-1]{text} and
 266             exists $quant->{text} )
 267         {
 268             $quants[-1]{text} .= $quant->{text};
 269         }
 270         else {
 271             push(@quants, $quant);
 272         }
 273     }
 274     return bless { Kids => [@quants] }, "P5RE::Alt";
 275 }
 276
 277 sub quant {
 278     my $atom = atom();
 279     return 0 unless $atom;
 280 #    $atom = bless { Kids => [$atom] }, "P5RE::Atom";
 281     if (s/^([*+?]\??|\{\d+(?:,\d*)?\}\??)//) {
 282         return bless { Kids => [$atom], type => $1 }, "P5RE::Quant";
 283     }
 284     return $atom;
 285 }
 286
 287 sub atom {
 288     my $re;
 289     if ($_ eq "") { return 0 }
 290     if (/^[)|]/) { return 0 }
 291
 292     # whitespace is special because we don't know if /x is in effect
 293     if ($extended) {
 294         if (s/^(?=\s|#)(\s*(?:#.*)?)//) { return bless { text => $1 }, "P5RE::White"; }
 295     }
 296
 297     # all the parenthesized forms
 298     if (s/^\(//) {
 299         if (s/^\?://) {
 300             $re = re('bracket');
 301         }
 302         elsif (s/^(\?#.*?)\)/)/) {
 303             $re = bless { rep => "($1)" }, "P5RE::Comment";
 304         }
 305         elsif (s/^\?=//) {
 306             $re = re('lookahead');
 307         }
 308         elsif (s/^\?!//) {
 309             $re = re('neglookahead');
 310         }
 311         elsif (s/^\?<=//) {
 312             $re = re('lookbehind');
 313         }
 314         elsif (s/^\?<!//) {
 315             $re = re('neglookbehind');
 316         }
 317         elsif (s/^\?>//) {
 318             $re = re('nobacktrack');
 319         }
 320         elsif (s/^(\?\??\{.*?\})\)/)/) {
 321             $re = bless { rep => "($1)" }, "P5RE::Closure";
 322         }
 323         elsif (s/^(\?\(\d+\))//) {
 324             my $mods = $1;
 325             $re = re('conditional');
 326             $re->{modifiers} = "$mods";
 327         }
 328         elsif (s/^\?(?=\(\?)//) {
 329             my $mods = $1;
 330             my $cond = atom();
 331             $re = re('conditional');
 332             unshift(@{$re->{Kids}}, $cond);
 333         }
 334         elsif (s/^(\?[-imsx]+)://) {
 335             my $mods = $1;
 336             local $extended = $extended;
 337             local $insensitive = $insensitive;
 338             local $multiline = $multiline;
 339             local $singleline = $singleline;
 340             setmods($mods);
 341             $re = re('bracket');
 342             $re->{modifiers} = "$mods";
 343         }
 344         elsif (s/^(\?[-imsx]+)//) {
 345             my $mods = $1;
 346             $re = bless { modifiers => "($mods)" }, "P5RE::Mod";
 347             setmods($mods);
 348         }
 349         elsif (s/^\?//) {
 350             $re = re('UNRECOGNIZED');
 351         }
 352         else {
 353             $re = re('capture');
 354         }
 355
 356         if (not s/^\)//) { die "Expected right paren at: '$_'" }
 357         return $re;
 358     }
 359
 360     # special meta
 361     if (s/^\.//) {
 362         my $s = $singleline ? '.' : '\N';
 363         return bless { rep => '.', sem => $s }, "P5RE::Meta";
 364     }
 365     if (s/^\^//) {
 366         my $s = $multiline ? '^^' : '^';
 367         return bless { rep => '^', sem => $s }, "P5RE::Meta";
 368     }
 369     if (s/^\$(?:$|(?=[|)]))//) {
 370         my $s = $multiline ? '$$' : '$';
 371         return bless { rep => '$', sem => $s }, "P5RE::Meta";
 372     }
 373     if (s/^([\$\@](\w+|.))//) {         # XXX need to handle subscripts here
 374         return bless { name => $1 }, "P5RE::Var";
 375     }
 376
 377     # character classes
 378     if (s/^\[//) {
 379         my $re = cclass();
 380         if (not s/^\]//) { die "Expected right paren at: '$_'" }
 381         return $re;
 382     }
 383
 384     # backwhacks
 385     if (/^\\(?=.)/) {
 386         return bless { rep => onechar() }, "P5RE::Meta";
 387     }
 388
 389     # optimization, would happen anyway
 390     if (s/^(\w+)//) { return bless { text => $1 }, "P5RE::Char"; }
 391
 392     # random character
 393     if (s/^(.)//) { return bless { text => $1 }, "P5RE::Char"; }
 394 }
 395
 396 sub cclass {
 397     my @cclass;
 398     my $cclass = "";
 399     my $neg = 0;
 400     if (s/^\^//) { $neg = 1 }
 401     if (s/^([\]\-])//) { $cclass .= $1 }
 402
 403     while ($_ ne "" and not /^\]/) {
 404         # backwhacks
 405         if (/^\\(?=.)|.-/) {
 406             my $o1 = onecharobj();
 407             if ($cclass ne "") {
 408                 push @cclass, bless { text => $cclass }, "P5RE::Char";
 409                 $cclass = "";
 410             }
 411
 412             if (s/^-(?=[^]])//) {
 413                 my $o2 = onecharobj();
 414                 push @cclass, bless { Kids => [$o1, $o2] }, "P5RE::Range";
 415             }
 416             else {
 417                 push @cclass, $o1;
 418             }
 419         }
 420         elsif (s/^(\[([:=.])\^?\w*\2\])//) {
 421             if ($cclass ne "") {
 422                 push @cclass, bless { text => $cclass }, "P5RE::Char";
 423                 $cclass = "";
 424             }
 425             push @cclass, bless { rep => $1 }, "P5RE::Meta";
 426         }
 427         else {
 428             $cclass .= onechar();
 429         }
 430     }
 431
 432     if ($cclass ne "") {
 433         push @cclass, bless { text => $cclass }, "P5RE::Char";
 434     }
 435     return bless { Kids => [@cclass], neg => $neg }, "P5RE::CClass";
 436 }
 437
 438 sub onecharobj {
 439     my $ch = onechar();
 440     if ($ch =~ /^\\/) {
 441         $ch = bless { rep => $ch }, "P5RE::Meta";
 442     }
 443     else {
 444         $ch = bless { text => $ch }, "P5RE::Char";
 445     }
 446 }
 447
 448 sub onechar {
 449     die "Oops, short cclass" unless s/^(.)//;
 450     my $ch = $1;
 451     if ($ch eq '\\') {
 452         if (s/^([rntf]|[0-7]{1,4})//) { $ch .= $1 }
 453         elsif (s/^(x[0-9a-fA-f]{1,2})//) { $ch .= $1 }
 454         elsif (s/^(x\{[0-9a-fA-f]+\})//) { $ch .= $1 }
 455         elsif (s/^([NpP]\{.*?\})//) { $ch .= $1 }
 456         elsif (s/^([cpP].)//) { $ch .= $1 }
 457         elsif (s/^(.)//) { $ch .= $1 }
 458         else {
 459             die "Oops, short backwhack";
 460         }
 461     }
 462     return $ch;
 463 }
 464
 465 sub setmods {
 466     my $mods = shift;
 467     if ($mods =~ /\-.*x/) {
 468         $extended = 0;
 469     }
 470     elsif ($mods =~ /x/) {
 471         $extended = 1;
 472     }
 473     if ($mods =~ /\-.*i/) {
 474         $insensitive = 0;
 475     }
 476     elsif ($mods =~ /i/) {
 477         $insensitive = 1;
 478     }
 479     if ($mods =~ /\-.*m/) {
 480         $multiline = 0;
 481     }
 482     elsif ($mods =~ /m/) {
 483         $multiline = 1;
 484     }
 485     if ($mods =~ /\-.*s/) {
 486         $singleline = 0;
 487     }
 488     elsif ($mods =~ /s/) {
 489         $singleline = 1;
 490     }
 491 }
 492
 493 sub reparse {
 494     local $_ = shift;
 495     s/^(\W)(.*)\1(\w*)$/$2/;
 496     my $mod = $3;
 497     substr($_,0,0) = "(?$mod)" if $mod ne "";
 498     print $_,"\n";
 499     return re('re');
 500 }
 501
 502 if (not caller) {
 503     while (my $line = <>) {
 504         chop $line;
 505         my $x = P5RE::reparse($line);
 506         print $x->xml();
 507         print "#######################################\n";
 508     }
 509 }
 510