projects / p5sagit/p5-mst-13.2.git / blame
? search:
summary | shortlog | log | commit | commitdiff | tree
blob | history | HEAD
Rename mad/nomad to mad/Nomad.pm
[p5sagit/p5-mst-13.2.git] / mad / Nomad.pm
CommitLineData
6a28abbc 1#!/usr/bin/perl
2
3# Suboptimal things:
4# ast type info is generally still implicit
5# the combined madness calls are actually losing type information
6# brace madprops tend to be too low in the tree
7# could use about 18 more refactorings...
8# lots of unused cruft left around from previous refactorings
9
10use strict;
11use warnings;
12use Carp;
6a28abbc 13
14use P5AST;
15use P5re;
16
17my $dowarn = 0;
18my $YAML = 0;
19my $deinterpolate;
20
cbe583b9 21while (@ARGV and $ARGV[0] =~ /^-./) {
6a28abbc 22 my $switch = shift;
23 if ($switch eq '-w') {
24 $dowarn = 1;
25 }
26 elsif ($switch eq '-Y') {
27 $YAML = 1;
28 }
29 elsif ($switch eq '-d') {
30 $deinterpolate = 1;
31 }
32 else {
33 die "Unrecognized switch: -$switch";
34 }
35}
36
37@ARGV = ('foo.xml') unless @ARGV;
38my $filename = shift;
39
40$::curstate = 0;
41$::prevstate = 0;
42$::curenc = 1; # start in iso-8859-1, sigh...
43
44$::H = "HeredocHere000";
45%::H = ();
46
47my @enc = (
48 'utf-8',
49 'iso-8859-1',
50);
51
52my %enc = (
53 'utf-8' => 0,
54 'iso-8859-1' => 1,
55);
56
57my %madtype = (
58 '$' => 'p5::sigil',
59 '@' => 'p5::sigil',
60 '%' => 'p5::sigil',
61 '&' => 'p5::sigil',
62 '*' => 'p5::sigil',
63 'o' => 'p5::operator',
64 '~' => 'p5::operator',
65 '+' => 'p5::punct',
66 '?' => 'p5::punct',
67 ':' => 'p5::punct',
68 ',' => 'p5::punct',
69 ';' => 'p5::punct',
70 '#' => 'p5::punct',
71 '(' => 'p5::opener',
72 ')' => 'p5::closer',
73 '[' => 'p5::opener',
74 ']' => 'p5::closer',
75 '{' => 'p5::opener',
76 '}' => 'p5::closer',
77 '1' => 'p5::punct',
78 '2' => 'p5::punct',
79 'a' => 'p5::operator',
80 'A' => 'p5::operator',
81 'd' => 'p5::declarator',
82 'E' => 'p5::text',
83 'L' => 'p5::label',
84 'm' => 'p5::remod',
85# 'n' => 'p5::name',
86 'q' => 'p5::openquote',
87 'Q' => 'p5::closequote',
88 '=' => 'p5::text',
89 'R' => 'p5::text',
90 's' => 'p5::text',
91 's' => 'p5::declarator',
92# 'V' => 'p5::version',
93 'X' => 'p5::token',
94);
95
96$SIG{__DIE__} = sub {
97 my $e = shift;
98 $e =~ s/\n$/\n [NODE $filename line $::prevstate->{line}]/ if $::prevstate;
99 confess $e;
100};
101
102use Data::Dumper;
103$Data::Dumper::Indent = 1;
104$Data::Dumper::Quotekeys = 0;
105
106sub d {
107 my $text = Dumper(@_);
108 # doesn't scale well, alas
109 1 while $text =~ s/(.*)^([^\n]*)bless\( \{\n(.*?)^(\s*\}), '([^']*)' \)([^\n]*)/$1$2$5 {\n$3$4$6 # $5/ms;
110 $text =~ s/PLXML:://g;
111 if ($text) {
112 my ($package, $filename, $line) = caller;
113 my $subroutine = (caller(1))[3];
114 $text =~ s/\n?\z/, called from $subroutine, line $line\n/;
115 warn $text;
116 }
117};
118
119{
120
121 my %xmlrepl = (
122 '&' => '&',
123 "'" => ''',
124 '"' => '&dquo;',
125 '<' => '&lt;',
126 '>' => '&gt;',
127 "\n" => '&#10;',
128 "\t" => '&#9;',
129 );
130
131 sub x {
132 my $indent = 0;
133 if (@_ > 1) {
134 warn xdolist($indent,"LIST",@_);
135 }
136 else {
137 my $type = ref $_[0];
138 if ($type) {
139 warn xdoitem($indent,$type,@_);
140 }
141 else {
142 warn xdoitem($indent,"ITEM",@_);
143 }
144 }
145 }
146
147 sub xdolist {
148 my $indent = shift;
149 my $tag = shift;
150 my $in = ' ' x ($indent * 2);
151 my $result;
152 $result .= "$in<$tag>\n" if defined $tag;
153 for my $it (@_) {
154 my $itt = ref $it || "ITEM";
155 $itt =~ s/::/:/g;
156 $result .= xdoitem($indent+1,$itt,$it);
157 }
158 $result .= "$in</$tag>\n" if defined $tag;
159 return $result;
160 }
161
162 sub xdohash {
163 my $indent = shift;
164 my $tag = shift;
165 my $hash = shift;
166 my $in = ' ' x ($indent * 2);
167 my $result = "$in<$tag>\n";
168 my @keys = sort keys %$hash;
169 my $longest = 0;
170 for my $k (@keys) {
171 $longest = length($k) if length($k) > $longest;
172 }
173 my $K;
174 for my $k (@keys) {
175 my $tmp;
176 $K = $$hash{$k}, next if $k eq 'Kids';
177 my $sp = ' ' x ($longest - length($k));
178 if (ref $$hash{$k}) {
179 $tmp = xdoitem($indent+1,"kv",$$hash{$k});
180 $tmp =~ s!^ *<kv>\n *</kv>!$in <kv/>!;
181 }
182 else {
183 $tmp = xdoitem($indent+1,"kv",$$hash{$k});
184 }
185 $k =~ s/([\t\n'"<>&])/$xmlrepl{$1}/g;
186 $tmp =~ s/<kv/<kv k='$k'$sp/ or
187 $tmp =~ s/^(.*)$/$in <kv k='$k'>\n$in $1$in <\/kv>\n/s;
188 $result .= $tmp;
189 }
190 if ($K and @$K) {
191 $result .= xdolist($indent, undef, @$K);
192 }
193 $result .= "$in</$tag>\n";
194 }
195
196 sub xdoitem {
197 my $indent = shift;
198 my $tag = shift;
199 my $item = shift;
200 my $in = ' ' x ($indent * 2);
201 my $r = ref $item;
202 if (not $r) {
203 $item =~ s/([\t\n'"<>&])/$xmlrepl{$1}/g;
204 return "$in<$tag>$item</$tag>\n";
205 }
206 (my $newtag = $r) =~ s/::/:/g;
207 my $t = "$item";
208 if ($t =~ /\bARRAY\b/) {
209 if (@{$item}) {
210 return xdolist($indent,$tag,@{$item});
211 }
212 else {
213 return "$in<$tag />\n";
214 }
215 }
216 if ($t =~ /\bHASH\b/) {
217 return xdohash($indent,$tag,$item);
218 }
219 if ($r =~ /^p5::/) {
220 return "$in<$newtag>$$item</$newtag>\n";
221 }
222 else {
223 return "$in<$newtag type='$r'/>\n";
224 }
225 }
226
227 my %trepl = (
228 "'" => '\\\'',
229 '"' => '\\"',
230 "\n" => '\\n',
231 "\t" => '\\t',
232 );
233
234 sub t {
235 my $indent = 0;
236 if (@_ > 1) {
237 tdolist($indent,"LIST",@_);
238 }
239 else {
240 my $type = ref $_[0];
241 if ($type) {
242 tdoitem($indent,$type,@_);
243 }
244 else {
245 tdoitem($indent,"ITEM",@_);
246 }
247 }
248 print STDERR "\n";
249 }
250
251 sub tdolist {
252 my $indent = shift;
253 my $tag = shift || "ARRAY";
254 my $in = ' ' x ($indent * 2);
255 if (@_) {
256 print STDERR "[\n";
257 for my $it (@_) {
258 my $itt = ref $it || "ITEM";
259 print STDERR $in," ";
260 tdoitem($indent+1,$itt,$it);
261 print STDERR "\n";
262 }
263 print STDERR "$in]";
264 }
265 else {
266 print STDERR "[]";
267 }
268 }
269
270 sub tdohash {
271 my $indent = shift;
272 my $tag = shift;
273 my $hash = shift;
274 my $in = ' ' x ($indent * 2);
275
276 print STDERR "$tag => {\n";
277
278 my @keys = sort keys %$hash;
279 my $longest = 0;
280 for my $k (@keys) {
281 $longest = length($k) if length($k) > $longest;
282 }
283 my $K;
284 for my $k (@keys) {
285 my $sp = ' ' x ($longest - length($k));
286 print STDERR "$in $k$sp => ";
287 tdoitem($indent+1,"",$$hash{$k});
288 if ($k eq 'Kids') {
289 print STDERR " # Kids";
290 }
291 print STDERR "\n";
292 }
293 print STDERR "$in} # $tag";
294 }
295
296 sub tdoitem {
297 my $indent = shift;
298 my $tag = shift;
299 my $item = shift;
300 if (not defined $item) {
301 print STDERR "UNDEF";
302 return;
303 }
304# my $in = ' ' x ($indent * 2);
305 my $r = ref $item;
306 if (not $r) {
307 $item =~ s/([\t\n"])/$trepl{$1}/g;
308 print STDERR "\"$item\"";
309 return;
310 }
311 my $t = "$item";
312 if ($r =~ /^p5::/) {
313 my $str = $$item{uni};
314 my $enc = $enc[$$item{enc}] . ' ';
315 $enc =~ s/iso-8859-1 //;
316 $str =~ s/([\t\n"])/$trepl{$1}/g;
317 print STDERR "$r $enc\"$str\"";
318 }
319 elsif ($t =~ /\bARRAY\b/) {
320 tdolist($indent,$tag,@{$item});
321 }
322 elsif ($t =~ /\bHASH\b/) {
323 tdohash($indent,$tag,$item);
324 }
325 else {
326 print STDERR "$r type='$r'";
327 }
328 }
329}
330
331sub encnum {
332 my $encname = shift;
333 if (not exists $enc{$encname}) {
334 push @enc, $encname;
335 return $enc{$encname} = $#enc;
336 }
337 return $enc{$encname};
338}
339
340use PLXML;
341
342use XML::Parser;
343my $p1 = new XML::Parser(Style => 'Objects', Pkg => 'PLXML');
344$p1->setHandlers('Char' => sub { warn "Chars $_[1]" if $_[1] =~ /\S/; });
345
346# First slurp XML into tree of objects.
347
348my $root = $p1->parsefile($filename);
349
350# Now turn XML tree into something more like an AST.
351
352PLXML::prepreproc($root->[0]);
353my $ast = P5AST->new('Kids' => [$root->[0]->ast()]);
354#::t($ast);
355
356if ($YAML) {
357 require YAML::Syck;
358 print YAML::Syck::Dump($ast);
359 exit;
360}
361
362# Finally, walk AST to produce new program.
363
364my $text = $ast->p5text(); # returns encoded, must output raw
365print $text;
366
367package p5::text;
368
369use Encode;
370
371sub new {
372 my $class = shift;
373 my $text = shift;
374 die "Too many args to new" if @_;
375 die "Attempt to bless non-text $text" if ref $text;
376 return bless( { uni => $text,
377 enc => $::curenc,
378 }, $class);
379}
380
381sub uni { my $self = shift; $$self{uni}; } # internal stuff all in utf8
382
383sub enc {
384 my $self = shift;
385 my $enc = $enc[$$self{enc} || 0];
386 return encode($enc, $$self{uni});
387}
388
389package p5::closequote; BEGIN { @p5::closequote::ISA = 'p5::punct'; }
390package p5::closer; BEGIN { @p5::closer::ISA = 'p5::punct'; }
391package p5::declarator; BEGIN { @p5::declarator::ISA = 'p5::token'; }
392package p5::junk; BEGIN { @p5::junk::ISA = 'p5::text'; }
393package p5::label; BEGIN { @p5::label::ISA = 'p5::token'; }
394#package p5::name; BEGIN { @p5::name::ISA = 'p5::token'; }
395package p5::opener; BEGIN { @p5::opener::ISA = 'p5::punct'; }
396package p5::openquote; BEGIN { @p5::openquote::ISA = 'p5::punct'; }
397package p5::operator; BEGIN { @p5::operator::ISA = 'p5::token'; }
398package p5::punct; BEGIN { @p5::punct::ISA = 'p5::token'; }
399package p5::remod; BEGIN { @p5::remod::ISA = 'p5::token'; }
400package p5::sigil; BEGIN { @p5::sigil::ISA = 'p5::punct'; }
401package p5::token; BEGIN { @p5::token::ISA = 'p5::text'; }
402#package p5::version; BEGIN { @p5::version::ISA = 'p5::token'; }
403
404################################################################
405# Routines to turn XML tree into an AST. Mostly this amounts to hoisting
406# misplaced nodes and flattening various things into lists.
407
408package PLXML;
409
410sub AUTOLOAD {
411 ::x("AUTOLOAD $PLXML::AUTOLOAD", @_);
412 return "[[[ $PLXML::AUTOLOAD ]]]";
413}
414
415sub prepreproc {
416 my $self = shift;
417 my $kids = $$self{Kids};
418 $self->{mp} = {};
419 if (defined $kids) {
420 my $i;
421 for ($i = 0; $i < @$kids; $i++) {
422 if (ref $kids->[$i] eq "PLXML::madprops") {
423 $self->{mp} = splice(@$kids, $i, 1)->hash($self,@_);
424 $i--;
425 next;
426 }
427 else {
428 prepreproc($kids->[$i], $self, @_);
429 }
430 }
431 }
432}
433
434sub preproc {
435 my $self = shift;
436 if (ref $self eq 'PLXML::op_null' and $$self{was}) {
437 return "PLXML::op_$$self{was}"->key();
438 }
439 else {
440 return $self->key();
441 }
442}
443
444sub newtype {
445 my $self = shift;
446 my $t = ref $self || $self;
447 $t = "PLXML::op_$$self{was}" if $t eq 'PLXML::op_null' and $$self{was};
448 $t =~ s/PLXML/P5AST/ or die "Bad type: $t";
449 return $t;
450}
451
452sub madness {
453 my $self = shift;
454 my @keys = split(' ', shift);
455 my @vals = ();
456 for my $key (@keys) {
457 my $madprop = $self->{mp}{$key};
458 next unless defined $madprop;
459 if (ref $madprop eq 'PLXML::mad_op') {
460 if ($key eq 'b') {
461 push @vals, $madprop->blockast($self, @_);
462 }
463 else {
464 push @vals, $madprop->ast($self, @_);
465 }
466 next;
467 }
468 my $white;
469 if ($white = $self->{mp}{"_$key"}) {
470 push @vals, p5::junk->new($white);
471 }
472 my $type = $madtype{$key} || "p5::token";
473 push @vals, $type->new($madprop);
474 if ($white = $self->{mp}{"#$key"}) {
475 push @vals, p5::junk->new($white);
476 }
477 }
478 @vals;
479}
480
481sub blockast {
482 my $self = shift;
483 $self->ast(@_);
484}
485
486sub ast {
487 my $self = shift;
488
489 my @newkids;
490 for my $kid (@{$$self{Kids}}) {
491 push @newkids, $kid->ast($self, @_);
492 }
493 return $self->newtype->new(Kids => [uc $self->key(), "(", @newkids, ")"]);
494}
495
496sub op {
497 my $self = shift;
498 my $desc = $self->desc();
499 if ($desc =~ /\((.*?)\)/) {
500 return $1;
501 }
502 else {
503 return " <<" . $self->key() . ">> ";
504 }
505}
506
507sub mp {
508 my $self = shift;
509 return $self->{mp};
510}
511
512package PLXML::Characters;
513
514sub ast { die "oops" }
515sub pair { die "oops" }
516
517package PLXML::madprops;
518
519sub ast {
520 die "oops madprops";
521}
522
523sub hash {
524 my $self = shift;
525 my @pairs;
526 my %hash = ();
527 my $firstthing = '';
528 my $lastthing = '';
529
530 # We need to guarantee key uniqueness at this point.
531 for my $kid (@{$$self{Kids}}) {
532 my ($k,$v) = $kid->pair($self, @_);
533 $firstthing ||= $k;
534 if ($k =~ /^[_#]$/) { # rekey whitespace according to preceding entry
535 $k .= $lastthing; # (which is actually the token the whitespace is before)
536 }
537 else {
538 $k .= 'x' while exists $hash{$k};
539 $lastthing = $k;
540 }
541 $hash{$k} = $v;
542 }
543 $hash{FIRST} = $firstthing;
544 $hash{LAST} = $lastthing;
545 return \%hash;
546}
547
548package PLXML::mad_op;
549
550sub pair {
551 my $self = shift;
552 my $key = $$self{key};
553 return $key,$self;
554}
555
556sub ast {
557 my $self = shift;
558 $self->prepreproc(@_);
559 my @vals;
560 for my $kid (@{$$self{Kids}}) {
561 push @vals, $kid->ast($self, @_);
562 }
563 if (@vals == 1) {
564 return @vals;
565 }
566 else {
567 return P5AST::op_list->new(Kids => [@vals]);
568 }
569}
570
571sub blockast {
572 my $self = shift;
573 $self->prepreproc(@_);
574 my @vals;
575 for my $kid (@{$$self{Kids}}) {
576 push @vals, $kid->blockast($self, @_);
577 }
578 if (@vals == 1) {
579 return @vals;
580 }
581 else {
582 return P5AST::op_lineseq->new(Kids => [@vals]);
583 }
584}
585
586package PLXML::mad_pv;
587
588sub pair {
589 my $self = shift;
590 my $key = $$self{key};
591 my $val = $$self{val};
592 $val =~ s/STUPIDXML\(#x(\w+)\)/chr(hex $1)/eg;
593 return $key,$val;
594}
595
596package PLXML::mad_sv;
597
598sub pair {
599 my $self = shift;
600 my $key = $$self{key};
601 my $val = $$self{val};
602 $val =~ s/STUPIDXML\(#x(\w+)\)/chr(hex $1)/eg;
603 return $key,$val;
604}
605
606package PLXML::baseop;
607
608sub ast {
609 my $self = shift;
610
611 my @retval;
612 my @newkids;
613 push @retval, $self->madness('M ox');
614 for my $kid (@{$$self{Kids}}) {
615 push @newkids, $kid->ast($self, @_);
616 }
617 if (@newkids) {
618 push @retval, uc $self->key(), "(", @newkids , ")";
619 }
620 else {
621 push @retval, $self->madness('o ( )');
622 }
623 return $self->newtype->new(Kids => [@retval]);
624}
625
626package PLXML::baseop_unop;
627
628sub ast {
629 my $self = shift;
630 my @newkids = $self->madness('d M ox o (');
631
632 if (exists $$self{Kids}) {
633 my $arg = $$self{Kids}[0];
634 push @newkids, $arg->ast($self, @_) if defined $arg;
635 }
636 push @newkids, $self->madness(')');
637
638 return $self->newtype()->new(Kids => [@newkids]);
639}
640
641package PLXML::binop;
642
643sub ast {
644 my $self = shift;
645 my @newkids;
646
647 push @newkids, $self->madness('M ox');
648
649 my $left = $$self{Kids}[0];
650 push @newkids, $left->ast($self, @_);
651
652 push @newkids, $self->madness('o');
653
654 my $right = $$self{Kids}[1];
655 if (defined $right) {
656 push @newkids, $right->ast($self, @_);
657 }
658
659 return $self->newtype->new(Kids => [@newkids]);
660}
661
662package PLXML::cop;
663
664package PLXML::filestatop;
665
666sub ast {
667 my $self = shift;
668
669 my @newkids = $self->madness('o (');
670
671 if (@{$$self{Kids}}) {
672 for my $kid (@{$$self{Kids}}) {
673 push @newkids, $kid->ast($self, @_);
674 }
675 }
676 if ($$self{mp}{O}) {
677 push @newkids, $self->madness('O');
678 }
679 push @newkids, $self->madness(')');
680
681 return $self->newtype->new(Kids => [@newkids]);
682}
683
684package PLXML::listop;
685
686sub ast {
687 my $self = shift;
688
689 my @retval;
690 my @before;
691 my @after;
692 if (@before = $self->madness('M')) {
693 push @before, $self->madness('ox'); # o is the function name
694 }
695 if (@retval = $self->madness('X')) {
696 push @before, $self->madness('o x');
697 return P5AST::listop->new(Kids => [@before,@retval]);
698 }
699
cbe583b9 700 push @retval, $self->madness('o ( [ {');
6a28abbc 701
702 my @newkids;
703 for my $kid (@{$$self{Kids}}) {
704 next if ref $kid eq 'PLXML::op_pushmark';
705 next if ref $kid eq 'PLXML::op_null' and
706 defined $$kid{was} and $$kid{was} eq 'pushmark';
707 push @newkids, $kid->ast($self, @_);
708 }
709
710 my $x = "";
711
712 if ($$self{mp}{S}) {
713 push @retval, $self->madness('S');
714 }
715 push @retval, @newkids;
716
cbe583b9 717 push @retval, $self->madness('} ] )');
6a28abbc 718 return $self->newtype->new(Kids => [@before,@retval,@after]);
719}
720
721package PLXML::logop;
722
723sub ast {
724 my $self = shift;
725
726 my @newkids;
727 push @newkids, $self->madness('o (');
728 for my $kid (@{$$self{Kids}}) {
729 push @newkids, $kid->ast($self, @_);
730 }
731 push @newkids, $self->madness(')');
732 return $self->newtype->new(Kids => [@newkids]);
733}
734
735package PLXML::loop;
736
737package PLXML::loopexop;
738
739sub ast {
740 my $self = shift;
741 my @newkids = $self->madness('o (');
742
743 if ($$self{mp}{L} or not $$self{flags} =~ /\bSPECIAL\b/) {
744 my @label = $self->madness('L');
745 if (@label) {
746 push @newkids, @label;
747 }
748 else {
749 my $arg = $$self{Kids}[0];
750 push @newkids, $arg->ast($self, @_) if defined $arg;
751 }
752 }
753 push @newkids, $self->madness(')');
754
755 return $self->newtype->new(Kids => [@newkids]);
756}
757
758
759package PLXML::padop;
760
761package PLXML::padop_svop;
762
763package PLXML::pmop;
764
765sub ast {
766 my $self = shift;
767
768 return P5AST::pmop->new(Kids => []) unless exists $$self{flags};
769
770 my $bits = $self->fetchbits($$self{flags},@_);
771
772 my @newkids;
773 if ($bits->{binding}) {
774 push @newkids, $bits->{binding};
775 push @newkids, $self->madness('~');
776 }
777 if (exists $bits->{regcomp} and $bits->{regcomp}) {
778 my @front = $self->madness('q');
779 my @back = $self->madness('Q');
780 push @newkids, @front, $bits->{regcomp}, @back,
781 $self->madness('m');
782 }
783 elsif ($$self{mp}{q}) {
784 push @newkids, $self->madness('q = Q m');
785 }
786 elsif ($$self{mp}{X}) {
787 push @newkids, $self->madness('X m');
788 }
789 else {
790 push @newkids, $self->madness('e m');
791 }
792
793 return $self->newtype->new(Kids => [@newkids]);
794}
795
796sub innerpmop {
797 my $pmop = shift;
798 my $bits = shift;
799 for my $key (grep {!/^Kids/} keys %$pmop) {
800 $bits->{$key} = $pmop->{$key};
801 }
802
803 # Have to delete all the fake evals of the repl. This is a pain...
804 if (@{$$pmop{Kids}}) {
805 my $really = $$pmop{Kids}[0]{Kids}[0];
806 if (ref $really eq 'PLXML::op_substcont') {
807 $really = $$really{Kids}[0];
808 }
809 while ((ref $really) =~ /^PLXML::op_.*(null|entereval)/) {
810 if (exists $$really{was}) {
811 $bits->{repl} = $really->ast(@_);
812 return;
813 }
814 $really = $$really{Kids}[0];
815 }
816 if (ref $really eq 'PLXML::op_scope' and
817 @{$$really{Kids}} == 1 and
818 ref $$really{Kids}[0] eq 'PLXML::op_null' and
819 not @{$$really{Kids}[0]{Kids}})
820 {
821 $bits->{repl} = '';
822 return;
823 }
824 if (ref $really eq 'PLXML::op_leave' and
825 @{$$really{Kids}} == 2 and
826 ref $$really{Kids}[1] eq 'PLXML::op_null' and
827 not @{$$really{Kids}[1]{Kids}})
828 {
829 $bits->{repl} = '';
830 return;
831 }
832 if ((ref $really) =~ /^PLXML::op_(scope|leave)/) {
833 # should be at inner do {...} here, so skip that fakery too
834 $bits->{repl} = $really->newtype->new(Kids => [$really->PLXML::op_lineseq::lineseq(@_)]);
835 # but retrieve the whitespace before fake '}'
836 if ($$really{mp}{'_}'}) {
837 push(@{$bits->{repl}->{Kids}}, p5::junk->new($$really{mp}{'_}'}));
838 }
839 }
840 else { # something else, padsv probably
841 $bits->{repl} = $really->ast(@_);
842 }
843 }
844}
845
846sub fetchbits {
847 my $self = shift;
848 my $flags = shift || '';
849 my %bits = %$self;
850 my @kids = @{$$self{Kids}};
851 if (@kids) {
852 delete $bits{Kids};
853 my $arg = shift @kids;
854 innerpmop($arg,\%bits, $self, @_);
855 if ($flags =~ /STACKED/) {
856 $arg = shift @kids;
857 $bits{binding} = $arg->ast($self, @_);
858 }
859 if ($bits{when} ne "COMP" and @kids) {
860 $arg = pop @kids;
861 $bits{regcomp} = $arg->ast($self, @_);
862 }
863 if (not exists $bits{repl} and @kids) {
864 $arg = shift @kids;
865 $bits{repl} = $arg->ast($self, @_);
866 }
867 }
868 return \%bits;
869}
870
871package PLXML::pvop_svop;
872
873package PLXML::unop;
874
875sub ast {
876 my $self = shift;
877 my @newkids = $self->madness('o (');
878
879 if (exists $$self{Kids}) {
880 my $arg = $$self{Kids}[0];
881 push @newkids, $arg->ast($self, @_) if defined $arg;
882 }
883 push @newkids, $self->madness(')');
884
885 return $self->newtype->new(Kids => [@newkids]);
886}
887
888package PLXML;
889package PLXML::Characters;
890package PLXML::madprops;
891package PLXML::mad_op;
892package PLXML::mad_pv;
893package PLXML::baseop;
894package PLXML::baseop_unop;
895package PLXML::binop;
896package PLXML::cop;
897package PLXML::filestatop;
898package PLXML::listop;
899package PLXML::logop;
900package PLXML::loop;
901package PLXML::loopexop;
902package PLXML::padop;
903package PLXML::padop_svop;
904package PLXML::pmop;
905package PLXML::pvop_svop;
906package PLXML::unop;
907package PLXML::op_null;
908
909# Null nodes typed by first madprop.
910
911my %astmad;
912
913BEGIN {
914 %astmad = (
915 'p' => sub { # peg for #! line, etc.
916 my $self = shift;
917 my @newkids;
918 push @newkids, $self->madness('p px');
919 $::curstate = 0;
920 return P5AST::peg->new(Kids => [@newkids])
921 },
922 '(' => sub { # extra parens around the whole thing
923 my $self = shift;
924 my @newkids;
925 push @newkids, $self->madness('dx d o (');
926 for my $kid (@{$$self{Kids}}) {
927 push @newkids, $kid->ast($self, @_);
928 }
929 push @newkids, $self->madness(')');
930 return P5AST::parens->new(Kids => [@newkids])
931 },
932 '~' => sub { # binding operator
933 my $self = shift;
934 my @newkids;
935 push @newkids, $$self{Kids}[0]->ast($self,@_);
936 push @newkids, $self->madness('~');
937 push @newkids, $$self{Kids}[1]->ast($self,@_);
938 return P5AST::bindop->new(Kids => [@newkids])
939 },
940 ';' => sub { # null statements/blocks
941 my $self = shift;
942 my @newkids;
943 push @newkids, $self->madness('{ ; }');
944 $::curstate = 0;
945 return P5AST::nothing->new(Kids => [@newkids])
946 },
947 'I' => sub { # if or unless statement keyword
948 my $self = shift;
949 my @newkids;
950 push @newkids, $self->madness('L I (');
951 my @subkids;
952 for my $kid (@{$$self{Kids}}) {
953 push @subkids, $kid->ast($self, @_);
954 }
955 die "oops in op_null->new" unless @subkids == 1;
956 my $newself = $subkids[0];
957 @subkids = @{$$newself{Kids}};
958
959 unshift @{$subkids[0]{Kids}}, @newkids;
960 push @{$subkids[0]{Kids}}, $self->madness(')');
961 return bless($newself, 'P5AST::condstate');
962 },
963 'U' => sub { # use
964 my $self = shift;
965 my @newkids;
966 my @module = $self->madness('U');
967 my @args = $self->madness('A');
968 my $module = $module[-1]{Kids}[-1];
969 if ($module->uni eq 'bytes') {
970 $::curenc = ::encnum('iso-8859-1');
971 }
972 elsif ($module->uni eq 'utf8') {
973 if ($$self{mp}{o} eq 'no') {
974 $::curenc = ::encnum('iso-8859-1');
975 }
976 else {
977 $::curenc = ::encnum('utf-8');
978 }
979 }
980 elsif ($module->uni eq 'encoding') {
981 if ($$self{mp}{o} eq 'no') {
982 $::curenc = ::encnum('iso-8859-1');
983 }
984 else {
985 $::curenc = ::encnum(eval $args[0]->p5text); # XXX bletch
986 }
987 }
988 # (Surrounding {} ends up here if use is only thing in block.)
989 push @newkids, $self->madness('{ o');
990 push @newkids, @module;
991 push @newkids, $self->madness('V');
992 push @newkids, @args;
993 push @newkids, $self->madness('S ; }');
994 $::curstate = 0;
995 return P5AST::use->new(Kids => [@newkids])
996 },
997 '?' => sub { # ternary
998 my $self = shift;
999 my @newkids;
1000 my @subkids;
1001 my @condkids = @{$$self{Kids}[0]{Kids}};
1002
1003 push @newkids, $condkids[0]->ast($self,@_), $self->madness('?');
1004 push @newkids, $condkids[1]->ast($self,@_), $self->madness(':');
1005 push @newkids, $condkids[2]->ast($self,@_);
1006 return P5AST::ternary->new(Kids => [@newkids])
1007 },
1008 '&' => sub { # subroutine
1009 my $self = shift;
1010 my @newkids;
1011 push @newkids, $self->madness('d n s a : { & } ;');
1012 $::curstate = 0;
1013 return P5AST::sub->new(Kids => [@newkids])
1014 },
1015 'i' => sub { # modifier if
1016 my $self = shift;
1017 my @newkids;
1018 push @newkids, $self->madness('i');
1019 my $cond = $$self{Kids}[0];
1020 my @subkids;
1021 for my $kid (@{$$cond{Kids}}) {
1022 push @subkids, $kid->ast($self, @_);
1023 }
1024 push @newkids, shift @subkids;
1025 unshift @newkids, @subkids;
1026 return P5AST::condmod->new(Kids => [@newkids])
1027 },
1028 'P' => sub { # package declaration
1029 my $self = shift;
1030 my @newkids;
1031 push @newkids, $self->madness('o');
1032 push @newkids, $self->madness('P');
1033 push @newkids, $self->madness(';');
1034 $::curstate = 0;
1035 return P5AST::package->new(Kids => [@newkids])
1036 },
1037 'F' => sub { # format
1038 my $self = shift;
1039 my @newkids = $self->madness('F n b');
1040 $::curstate = 0;
1041 return P5AST::format->new(Kids => [@newkids])
1042 },
1043 'x' => sub { # qw literal
1044 my $self = shift;
1045 return P5AST::qwliteral->new(Kids => [$self->madness('x')])
1046 },
1047 'q' => sub { # random quote
1048 my $self = shift;
1049 return P5AST::quote->new(Kids => [$self->madness('q = Q')])
1050 },
1051 'X' => sub { # random literal
1052 my $self = shift;
1053 return P5AST::token->new(Kids => [$self->madness('X')])
1054 },
1055 ':' => sub { # attr list
1056 my $self = shift;
1057 return P5AST::attrlist->new(Kids => [$self->madness(':')])
1058 },
1059 ',' => sub { # "unary ," so to speak
1060 my $self = shift;
1061 my @newkids;
1062 push @newkids, $self->madness(',');
1063 push @newkids, $$self{Kids}[0]->ast($self,@_);
1064 return P5AST::listelem->new(Kids => [@newkids])
1065 },
1066 'C' => sub { # constant conditional
1067 my $self = shift;
1068 my @newkids;
1069 push @newkids, $$self{Kids}[0]->ast($self,@_);
1070 my @folded = $self->madness('C');
1071 if (@folded) {
1072 my @t = $self->madness('t');
1073 my @e = $self->madness('e');
1074 if (@e) {
1075 return P5AST::op_cond_expr->new(
1076 Kids => [
1077 $self->madness('I ('),
1078 @folded,
1079 $self->madness(') ?'),
1080 P5AST::op_cond_expr->new(Kids => [@newkids]),
1081 $self->madness(':'),
1082 @e
1083 ] );
1084 }
1085 else {
1086 return P5AST::op_cond_expr->new(
1087 Kids => [
1088 $self->madness('I ('),
1089 @folded,
1090 $self->madness(') ?'),
1091 @t,
1092 $self->madness(':'),
1093 @newkids
1094 ] );
1095 }
1096 }
1097 return P5AST::op_null->new(Kids => [@newkids])
1098 },
1099 '+' => sub { # unary +
1100 my $self = shift;
1101 my @newkids;
1102 push @newkids, $self->madness('+');
1103 push @newkids, $$self{Kids}[0]->ast($self,@_);
1104 return P5AST::preplus->new(Kids => [@newkids])
1105 },
1106 'D' => sub { # do block
1107 my $self = shift;
1108 my @newkids;
1109 push @newkids, $self->madness('D');
1110 push @newkids, $$self{Kids}[0]->ast($self,@_);
1111 return P5AST::doblock->new(Kids => [@newkids])
1112 },
1113 '3' => sub { # C-style for loop
1114 my $self = shift;
1115 my @newkids;
1116
1117 # What a mess!
1118 my (undef, $init, $lineseq) = @{$$self{Kids}[0]{Kids}};
1119 my (undef, $leaveloop) = @{$$lineseq{Kids}};
1120 my (undef, $null) = @{$$leaveloop{Kids}};
1121 my $and;
1122 my $cond;
1123 my $lineseq2;
1124 my $block;
1125 my $cont;
1126 if (exists $$null{was} and $$null{was} eq 'and') {
1127 ($lineseq2) = @{$$null{Kids}};
1128 }
1129 else {
1130 ($and) = @{$$null{Kids}};
1131 ($cond, $lineseq2) = @{$$and{Kids}};
1132 }
1133 if ($$lineseq2{mp}{'{'}) {
1134 $block = $lineseq2;
1135 }
1136 else {
1137 ($block, $cont) = @{$$lineseq2{Kids}};
1138 }
1139
1140 push @newkids, $self->madness('L 3 (');
1141 push @newkids, $init->ast($self,@_);
1142 push @newkids, $self->madness('1');
1143 if (defined $cond) {
1144 push @newkids, $cond->ast($self,@_);
1145 }
1146 elsif (defined $null) {
1147 push @newkids, $null->madness('1');
1148 }
1149 push @newkids, $self->madness('2');
1150 if (defined $cont) {
1151 push @newkids, $cont->ast($self,@_);
1152 }
1153 push @newkids, $self->madness(')');
1154 push @newkids, $block->blockast($self,@_);
1155 $::curstate = 0;
1156 return P5AST::cfor->new(Kids => [@newkids])
1157 },
1158 'o' => sub { # random useless operator
1159 my $self = shift;
1160 my @newkids;
1161 push @newkids, $self->madness('o');
1162 my $kind = $newkids[-1] || '';
1163 $kind = $kind->uni if ref $kind;
1164 my @subkids;
1165 for my $kid (@{$$self{Kids}}) {
1166 push @subkids, $kid->ast($self, @_);
1167 }
1168 if ($kind eq '=') { # stealth readline
1169 unshift(@newkids, shift(@subkids));
1170 push(@newkids, @subkids);
1171 return P5AST::op_aassign->new(Kids => [@newkids])
1172 }
1173 else {
1174 my $newself = $subkids[0];
1175 splice(@{$newself->{Kids}}, 1, 0,
1176 $self->madness('ox ('),
1177 @newkids,
1178 $self->madness(')')
1179 );
1180 return $newself;
1181 }
1182 },
1183 );
1184}
1185
1186# Null nodes are an untyped mess inside Perl. Instead of fixing it there,
1187# we derive an effective type either from the "was" field or the first madprop.
1188# (The individual routines select the actual new type.)
1189
1190sub ast {
1191 my $self = shift;
1192 my $was = $$self{was} || 'peg';
1193 my $mad = $$self{mp}{FIRST} || "unknown";
1194
1195 # First try for a "was".
1196 my $meth = "PLXML::op_${was}::astnull";
1197 if (exists &{$meth}) {
1198 return $self->$meth(@_);
1199 }
1200
1201 # Look at first madprop.
1202 if (exists $astmad{$mad}) {
1203 return $astmad{$mad}->($self);
1204 }
1205 warn "No mad $mad" unless $mad eq 'unknown';
1206
1207 # Do something generic.
1208 my @newkids;
1209 for my $kid (@{$$self{Kids}}) {
1210 push @newkids, $kid->ast($self, @_);
1211 }
1212 return $self->newtype->new(Kids => [@newkids]);
1213}
1214
1215sub blockast {
1216 my $self = shift;
1217 local $::curstate;
1218 local $::curenc = $::curenc;
1219 return $self->madness('{ ; }');
1220}
1221
1222package PLXML::op_stub;
1223
1224sub ast {
1225 my $self = shift;
1226 return $self->newtype->new(Kids => [$self->madness(', x ( ) q = Q')]);
1227}
1228
1229package PLXML::op_scalar;
1230
1231sub ast {
1232 my $self = shift;
1233
1234 my @pre = $self->madness('o q');
1235 my $op = pop @pre;
1236 if ($op->uni =~ /^<</) {
1237 my @newkids;
1238 my $opstub = bless { start => $op }, 'P5AST::heredoc';
1239 push @newkids, $opstub;
1240 push @newkids, $self->madness('(');
1241
1242 my @kids = @{$$self{Kids}};
1243
1244 my @divert;
1245 for my $kid (@kids) {
1246 next if ref $kid eq 'PLXML::op_pushmark';
1247 next if ref $kid eq 'PLXML::op_null' and
1248 defined $$kid{was} and $$kid{was} eq 'pushmark';
1249 push @divert, $kid->ast($self, @_);
1250 }
1251 $opstub->{doc} = P5AST::op_list->new(Kids => [@divert]);
1252 $opstub->{end} = ($self->madness('Q'))[-1];
1253
1254 push @newkids, $self->madness(')');
1255
1256 return $self->newtype->new(Kids => [@pre,@newkids]);
1257 }
1258 return $self->PLXML::baseop_unop::ast();
1259}
1260
1261package PLXML::op_pushmark;
1262
1263sub ast { () }
1264
1265package PLXML::op_wantarray;
1266package PLXML::op_const;
1267
1268sub astnull {
1269 my $self = shift;
1270 my @newkids;
1271 return unless $$self{mp};
1272 push @newkids, $self->madness('q = Q X : f O ( )');
1273 return P5AST::op_const->new(Kids => [@newkids]);
1274}
1275
1276sub ast {
1277 my $self = shift;
1278 return unless %{$$self{mp}};
1279
1280 my @before;
1281
1282 my $const;
1283 my @args = $self->madness('f');
1284 if (@args) {
1285 }
1286 elsif (exists $self->{mp}{q}) {
1287 push @args, $self->madness('d q');
1288 if ($args[-1]->uni =~ /^<</) {
1289 my $opstub = bless { start => pop(@args) }, 'P5AST::heredoc';
1290 $opstub->{doc} = P5AST::op_const->new(Kids => [$self->madness('=')]);
1291 $opstub->{end} = ($self->madness('Q'))[-1];
1292 push @args, $opstub;
1293 }
1294 else {
1295 push @args, $self->madness('= Q');
1296 }
1297 }
1298 elsif (exists $self->{mp}{X}) {
1299 push @before, $self->madness('d'); # was local $[ probably
1300 if (not $$self{mp}{O}) {
1301 push @before, $self->madness('o'); # was unary
1302 }
1303 my @X = $self->madness(': X');
1304 if (exists $$self{private} and $$self{private} =~ /BARE/) {
1305 return $self->newtype->new(Kids => [@X]);
1306 }
1307 my $X = pop @X;
1308 push @before, @X;
1309 @args = (
1310 $self->madness('x'),
1311 $X);
1312 if ($$self{mp}{O}) {
1313 push @args, $self->madness('o O');
1314 }
1315 }
1316 elsif (exists $self->{mp}{O}) {
1317 push @args, $self->madness('O');
1318 }
1319 elsif ($$self{private} =~ /\bBARE\b/) {
1320 @args = ($$self{PV});
1321 }
1322 elsif (exists $$self{mp}{o}) {
1323 @args = $self->madness('o');
1324 }
1325 elsif (exists $$self{PV}) {
1326 @args = ('"', $$self{PV}, '"');
1327 }
1328 elsif (exists $$self{NV}) {
1329 @args = $$self{NV};
1330 }
1331 elsif (exists $$self{IV}) {
1332 @args = $$self{IV};
1333 }
1334 else {
1335 @args = $self->SUPER::text(@_);
1336 }
1337 return $self->newtype->new(Kids => [@before, @args]);
1338}
1339
1340
1341package PLXML::op_gvsv;
1342
1343sub ast {
1344 my $self = shift;
1345 my @args;
1346 my @retval;
1347 for my $attr (qw/gv GV flags/) {
1348 if (exists $$self{$attr}) {
1349 push @args, $attr, $$self{$attr};
1350 }
1351 }
1352 push @retval, @args;
1353 push @retval, $self->madness('X');
1354 return $self->newtype->new(Kids => [@retval]);
1355}
1356
1357package PLXML::op_gv;
1358
1359sub ast {
1360 my $self = shift;
1361 my @newkids;
1362 push @newkids, $self->madness('X K');
1363
1364 return $self->newtype->new(Kids => [@newkids]);
1365}
1366
1367package PLXML::op_gelem;
1368
1369sub ast {
1370 my $self = shift;
1371
1372 local $::curstate; # in case there are statements in subscript
1373 local $::curenc = $::curenc;
1374 my @newkids;
1375 push @newkids, $self->madness('dx d');
1376 for my $kid (@{$$self{Kids}}) {
1377 push @newkids, $kid->ast($self, @_);
1378 }
1379 splice @newkids, -1, 0, $self->madness('o {');
1380 push @newkids, $self->madness('}');
1381
1382 return $self->newtype->new(Kids => [@newkids]);
1383}
1384
1385package PLXML::op_padsv;
1386
1387sub ast {
1388 my $self = shift;
1389 my @args;
1390 push @args, $self->madness('dx d ( $ )');
1391
1392 return $self->newtype->new(Kids => [@args]);
1393}
1394
1395package PLXML::op_padav;
1396
1397sub astnull { ast(@_) }
1398
1399sub ast {
1400 my $self = shift;
1401 my @retval;
1402 push @retval, $self->madness('dx d (');
1403 push @retval, $self->madness('$ @');
1404 push @retval, $self->madness(') o O');
1405 return $self->newtype->new(Kids => [@retval]);
1406}
1407
1408package PLXML::op_padhv;
1409
1410sub astnull { ast(@_) }
1411
1412sub ast {
1413 my $self = shift;
1414 my @retval;
1415 push @retval, $self->madness('dx d (');
1416 push @retval, $self->madness('$ @ %');
1417 push @retval, $self->madness(') o O');
1418 return $self->newtype->new(Kids => [@retval]);
1419}
1420
1421package PLXML::op_padany;
1422
1423package PLXML::op_pushre;
1424
1425sub ast {
1426 my $self = shift;
1427 if ($$self{mp}{q}) {
1428 return $self->madness('q = Q m');
1429 }
1430 if ($$self{mp}{X}) {
1431 return $self->madness('X m');
1432 }
1433 if ($$self{mp}{e}) {
1434 return $self->madness('e m');
1435 }
1436 return $$self{Kids}[1]->ast($self,@_), $self->madness('m');
1437}
1438
1439package PLXML::op_rv2gv;
1440
1441sub ast {
1442 my $self = shift;
1443
1444 my @newkids;
1445 push @newkids, $self->madness('dx d ( * $');
1446 push @newkids, $$self{Kids}[0]->ast();
1447 push @newkids, $self->madness(')');
1448 return $self->newtype->new(Kids => [@newkids]);
1449}
1450
1451package PLXML::op_rv2sv;
1452
1453sub astnull {
1454 my $self = shift;
1455 return P5AST::op_rv2sv->new(Kids => [$self->madness('O o dx d ( $ ) : a')]);
1456}
1457
1458sub ast {
1459 my $self = shift;
1460
1461 my @newkids;
1462 push @newkids, $self->madness('dx d ( $');
1463 if (ref $$self{Kids}[0] ne "PLXML::op_gv") {
1464 push @newkids, $$self{Kids}[0]->ast();
1465 }
1466 push @newkids, $self->madness(') : a');
1467 return $self->newtype->new(Kids => [@newkids]);
1468}
1469
1470package PLXML::op_av2arylen;
1471
1472sub ast {
1473 my $self = shift;
1474
1475 my @newkids;
1476 push @newkids, $$self{Kids}[0]->madness('l');
1477 push @newkids, $$self{Kids}[0]->ast();
1478 return $self->newtype->new(Kids => [@newkids]);
1479}
1480
1481package PLXML::op_rv2cv;
1482
1483sub astnull {
1484 my $self = shift;
1485 my @newkids;
1486 push @newkids, $self->madness('X');
1487 return @newkids if @newkids;
1488 if (exists $$self{mp}{'&'}) {
1489 push @newkids, $self->madness('&');
1490 if (@{$$self{Kids}}) {
1491 push @newkids, $$self{Kids}[0]->ast(@_);
1492 }
1493 }
1494 else {
1495 push @newkids, $$self{Kids}[0]->ast(@_);
1496 }
1497 return P5AST::op_rv2cv->new(Kids => [@newkids]);
1498}
1499
1500sub ast {
1501 my $self = shift;
1502
1503 my @newkids;
1504 push @newkids, $self->madness('&');
1505 if (@{$$self{Kids}}) {
1506 push @newkids, $$self{Kids}[0]->ast();
1507 }
1508 return $self->newtype->new(Kids => [@newkids]);
1509}
1510
1511package PLXML::op_anoncode;
1512
1513sub ast {
1514 my $self = shift;
1515 my $arg = $$self{Kids}[0];
1516 local $::curstate; # hide nested statements in sub
1517 local $::curenc = $::curenc;
1518 if (defined $arg) {
1519 return $arg->ast(@_);
1520 }
1521 return ';'; # XXX literal ; should come through somewhere
1522}
1523
1524package PLXML::op_prototype;
1525package PLXML::op_refgen;
1526
1527sub ast {
1528 my $self = shift;
1529 my @newkids = $self->madness('o s a');
1530
1531 if (exists $$self{Kids}) {
1532 my $arg = $$self{Kids}[0];
1533 push @newkids, $arg->ast($self, @_) if defined $arg;
1534 }
1535
1536 my $res = $self->newtype->new(Kids => [@newkids]);
1537 return $res;
1538}
1539
1540package PLXML::op_srefgen;
1541
1542sub ast {
1543 my @newkids;
1544 my $self = shift;
1545 if ($$self{mp}{FIRST} eq '{') {
1546 local $::curstate; # this is officially a block, so hide it
1547 local $::curenc = $::curenc;
1548 push @newkids, $self->madness('{');
1549 for my $kid (@{$$self{Kids}}) {
1550 push @newkids, $kid->ast($self, @_);
1551 }
1552 push @newkids, $self->madness('; }');
1553 return P5AST::op_stringify->new(Kids => [@newkids]);
1554 }
1555 else {
1556 push @newkids, $self->madness('o [');
1557 for my $kid (@{$$self{Kids}}) {
1558 push @newkids, $kid->ast($self, @_);
1559 }
1560 push @newkids, $self->madness(']');
1561 return P5AST::op_stringify->new(Kids => [@newkids]);
1562 }
1563}
1564
1565package PLXML::op_ref;
1566package PLXML::op_bless;
1567package PLXML::op_backtick;
1568
1569sub ast {
1570 my $self = shift;
1571 my @args;
1572 if (exists $self->{mp}{q}) {
1573 push @args, $self->madness('q');
1574 if ($args[-1]->uni =~ /^<</) {
1575 my $opstub = bless { start => $args[-1] }, 'P5AST::heredoc';
1576 $args[-1] = $opstub;
1577 $opstub->{doc} = P5AST::op_const->new(Kids => [$self->madness('=')]);
1578 $opstub->{end} = ($self->madness('Q'))[-1];
1579 }
1580 else {
1581 push @args, $self->madness('= Q');
1582 }
1583 }
1584 return $self->newtype->new(Kids => [@args]);
1585}
1586
1587package PLXML::op_glob;
1588
1589sub astnull {
1590 my $self = shift;
1591 my @retval = $self->madness('o q = Q');
1592 if (not @retval or $retval[-1]->uni eq 'glob') {
1593 push @retval, $self->madness('(');
1594 push @retval, $$self{Kids}[0]->ast($self,@_);
1595 push @retval, $self->madness(')');
1596 }
1597 return P5AST::op_glob->new(Kids => [@retval]);
1598}
1599
1600package PLXML::op_readline;
1601
1602sub astnull {
1603 my $self = shift;
1604 my @retval;
1605 if (exists $$self{mp}{q}) {
1606 @retval = $self->madness('q = Q');
1607 }
1608 elsif (exists $$self{mp}{X}) {
1609 @retval = $self->madness('X');
1610 }
1611 return P5AST::op_readline->new(Kids => [@retval]);
1612}
1613
1614sub ast {
1615 my $self = shift;
1616
1617 my @retval;
1618
1619 my @args;
1620 my $const;
1621 if (exists $$self{mp}{q}) {
1622 @args = $self->madness('q = Q');
1623 }
1624 elsif (exists $$self{mp}{X}) {
1625 @args = $self->madness('X');
1626 }
1627 elsif (exists $$self{GV}) {
1628 @args = $$self{IV};
1629 }
1630 elsif (@{$$self{Kids}}) {
1631 @args = $self->PLXML::unop::ast(@_);
1632 }
1633 else {
1634 @args = $self->SUPER::text(@_);
1635 }
1636 return $self->newtype->new(Kids => [@retval,@args]);
1637}
1638
1639
1640package PLXML::op_rcatline;
1641package PLXML::op_regcmaybe;
1642package PLXML::op_regcreset;
1643package PLXML::op_regcomp;
1644
1645sub ast {
1646 my $self = shift;
1647 $self->PLXML::unop::ast(@_);
1648}
1649
1650package PLXML::op_match;
1651
1652sub ast {
1653 my $self = shift;
1654 my $retval = $self->SUPER::ast(@_);
1655 my $p5re;
1656 if (not $p5re = $retval->p5text()) {
1657 $retval = $self->newtype->new(Kids => [$self->madness('X q = Q m')]);
1658 $p5re = $retval->p5text();
1659 }
1660 if ($deinterpolate) {
1661 $retval->{P5re} = P5re::qrparse($p5re);
1662 }
1663 return $retval;
1664}
1665
1666package PLXML::op_qr;
1667
1668sub ast {
1669 my $self = shift;
1670 my $retval;
1671 if (exists $$self{flags}) {
1672 $retval = $self->SUPER::ast(@_);
1673 }
1674 else {
1675 $retval = $self->newtype->new(Kids => [$self->madness('X q = Q m')]);
1676 }
1677 if ($deinterpolate) {
1678 my $p5re = $retval->p5text();
1679 $retval->{P5re} = P5re::qrparse($p5re);
1680 }
1681 return $retval;
1682}
1683
1684package PLXML::op_subst;
1685
1686sub ast {
1687 my $self = shift;
1688
1689 my $bits = $self->fetchbits($$self{flags},@_);
1690
1691 my @newkids;
1692 if ($bits->{binding}) {
1693 push @newkids, $bits->{binding};
1694 push @newkids, $self->madness('~');
1695 }
1696 my $X = p5::token->new($$self{mp}{X});
1697 my @lfirst = $self->madness('q');
1698 my @llast = $self->madness('Q');
1699 push @newkids,
1700 @lfirst,
1701 $self->madness('E'), # XXX s/b e probably
1702 @llast;
1703 my @rfirst = $self->madness('z');
1704 my @rlast = $self->madness('Z');
1705 my @mods = $self->madness('m');
1706 if ($rfirst[-1]->uni ne $llast[-1]->uni) {
1707 push @newkids, @rfirst;
1708 }
1709
1710 push @newkids, $bits->{repl}, @rlast, @mods;
1711
1712 my $retval = $self->newtype->new(Kids => [@newkids]);
1713 if ($deinterpolate) {
1714 my $p5re = $retval->p5text();
1715 $retval->{P5re} = P5re::qrparse($p5re);
1716 }
1717 return $retval;
1718}
1719
1720package PLXML::op_substcont;
1721package PLXML::op_trans;
1722
1723sub ast {
1724 my $self = shift;
1725
1726# my $bits = $self->fetchbits($$self{flags},@_);
1727#
1728 my @newkids;
1729 my @lfirst = $self->madness('q');
1730 my @llast = $self->madness('Q');
1731 push @newkids,
1732 @lfirst,
1733 $self->madness('E'),
1734 @llast;
1735 my @rfirst = $self->madness('z');
1736 my @repl = $self->madness('R');
1737 my @rlast = $self->madness('Z');
1738 my @mods = $self->madness('m');
1739 if ($rfirst[-1]->uni ne $llast[-1]->uni) {
1740 push @newkids, @rfirst;
1741 }
1742
1743 push @newkids, @repl, @rlast, @mods;
1744
1745 my $res = $self->newtype->new(Kids => [@newkids]);
1746 return $res;
1747}
1748
1749package PLXML::op_sassign;
1750
1751sub ast {
1752 my $self = shift;
1753 my @newkids;
1754
1755 my $right = $$self{Kids}[1];
1756 eval { push @newkids, $right->ast($self, @_); };
1757
1758 push @newkids, $self->madness('o');
1759
1760 my $left = $$self{Kids}[0];
1761 push @newkids, $left->ast($self, @_);
1762
1763 return $self->newtype->new(Kids => [@newkids]);
1764}
1765
1766package PLXML::op_aassign;
1767
1768sub astnull { ast(@_) }
1769
1770sub ast {
1771 my $self = shift;
1772 my @newkids;
1773
1774 my $right = $$self{Kids}[1];
1775 push @newkids, $right->ast($self, @_);
1776
1777 push @newkids, $self->madness('o');
1778
1779 my $left = $$self{Kids}[0];
1780 push @newkids, $left->ast($self, @_);
1781
1782 return $self->newtype->new(Kids => [@newkids]);
1783}
1784
1785package PLXML::op_chop;
1786package PLXML::op_schop;
1787package PLXML::op_chomp;
1788package PLXML::op_schomp;
1789package PLXML::op_defined;
1790package PLXML::op_undef;
1791package PLXML::op_study;
1792package PLXML::op_pos;
1793package PLXML::op_preinc;
1794
1795sub ast {
1796 my $self = shift;
1797 if ($$self{targ}) { # stealth post inc or dec
1798 return $self->PLXML::op_postinc::ast(@_);
1799 }
1800 return $self->SUPER::ast(@_);
1801}
1802
1803package PLXML::op_i_preinc;
1804
1805sub ast { my $self = shift; $self->PLXML::op_preinc::ast(@_); }
1806
1807package PLXML::op_predec;
1808
1809sub ast { my $self = shift; $self->PLXML::op_preinc::ast(@_); }
1810
1811package PLXML::op_i_predec;
1812
1813sub ast { my $self = shift; $self->PLXML::op_preinc::ast(@_); }
1814
1815package PLXML::op_postinc;
1816
1817sub ast {
1818 my $self = shift;
1819 my @newkids;
1820
1821 if (exists $$self{Kids}) {
1822 my $arg = $$self{Kids}[0];
1823 push @newkids, $arg->ast($self, @_) if defined $arg;
1824 }
1825 push @newkids, $self->madness('o');
1826
1827 my $res = $self->newtype->new(Kids => [@newkids]);
1828 return $res;
1829}
1830
1831package PLXML::op_i_postinc;
1832
1833sub ast { my $self = shift; $self->PLXML::op_postinc::ast(@_); }
1834
1835package PLXML::op_postdec;
1836
1837sub ast { my $self = shift; $self->PLXML::op_postinc::ast(@_); }
1838
1839package PLXML::op_i_postdec;
1840
1841sub ast { my $self = shift; $self->PLXML::op_postinc::ast(@_); }
1842
1843package PLXML::op_pow;
1844package PLXML::op_multiply;
1845package PLXML::op_i_multiply;
1846package PLXML::op_divide;
1847package PLXML::op_i_divide;
1848package PLXML::op_modulo;
1849package PLXML::op_i_modulo;
1850package PLXML::op_repeat;
1851
1852sub ast {
1853 my $self = shift;
1854 return $self->SUPER::ast(@_)
1855 unless exists $$self{private} and $$self{private} =~ /DOLIST/;
1856
1857 my $newself = $$self{Kids}[0]->ast($self,@_);
1858 splice @{$newself->{Kids}}, -1, 0, $self->madness('o');
1859
1860 return bless $newself, $self->newtype; # rebless the op_null
1861}
1862
1863package PLXML::op_add;
1864package PLXML::op_i_add;
1865package PLXML::op_subtract;
1866package PLXML::op_i_subtract;
1867package PLXML::op_concat;
1868
1869sub astnull {
1870 my $self = shift;
1871 my @newkids;
1872
1873 my @before;
1874 if (@before = $self->madness('M')) {
1875 push @before, $self->madness('ox'); # o is the .
1876 }
1877 my @after;
1878 my $left = $$self{Kids}[0];
1879 push @newkids, $left->ast($self, @_);
1880
1881 push @newkids, $self->madness('o');
1882
1883 my $right = $$self{Kids}[1];
1884 push @newkids, $right->ast($self, @_);
1885 return P5AST::op_concat->new(Kids => [@newkids]);
1886}
1887
1888sub ast {
1889 my $self = shift;
1890 my $parent = $_[0];
1891 my @newkids;
1892
1893 my @before;
1894 if (@before = $self->madness('M')) {
1895 push @before, $self->madness('ox'); # o is the .
1896 }
1897 my @after;
1898 my $left = $$self{Kids}[0];
1899 push @newkids, $left->ast($self, @_);
1900
1901 push @newkids, $self->madness('o');
1902
1903 my $right = $$self{Kids}[1];
1904 push @newkids, $right->ast($self, @_);
1905
1906 return $self->newtype->new(Kids => [@before, @newkids, @after]);
1907}
1908
1909package PLXML::op_stringify;
1910
1911sub astnull {
1912 ast(@_);
1913}
1914
1915sub ast {
1916 my $self = shift;
1917 my @newkids;
1918 my @front = $self->madness('q (');
1919 my @back = $self->madness(') Q');
1920 my @M = $self->madness('M');
1921 if (@M) {
1922 push @newkids, $M[0], $self->madness('o');
1923 }
1924 push @newkids, @front;
1925 for my $kid (@{$$self{Kids}}) {
1926 push @newkids, $kid->ast($self, @_);
1927 }
1928 push @newkids, @back;
1929 return P5AST::op_stringify->new(Kids => [@newkids]);
1930}
1931
1932package PLXML::op_left_shift;
1933package PLXML::op_right_shift;
1934package PLXML::op_lt;
1935package PLXML::op_i_lt;
1936package PLXML::op_gt;
1937package PLXML::op_i_gt;
1938package PLXML::op_le;
1939package PLXML::op_i_le;
1940package PLXML::op_ge;
1941package PLXML::op_i_ge;
1942package PLXML::op_eq;
1943package PLXML::op_i_eq;
1944package PLXML::op_ne;
1945package PLXML::op_i_ne;
1946package PLXML::op_ncmp;
1947package PLXML::op_i_ncmp;
1948package PLXML::op_slt;
1949package PLXML::op_sgt;
1950package PLXML::op_sle;
1951package PLXML::op_sge;
1952package PLXML::op_seq;
1953package PLXML::op_sne;
1954package PLXML::op_scmp;
1955package PLXML::op_bit_and;
1956package PLXML::op_bit_xor;
1957package PLXML::op_bit_or;
1958package PLXML::op_negate;
1959package PLXML::op_i_negate;
1960package PLXML::op_not;
1961
1962sub ast {
1963 my $self = shift;
1964 my @newkids = $self->madness('o (');
1965 my @swap;
1966 if (@newkids and $newkids[-1]->uni eq '!~') {
1967 @swap = @newkids;
1968 @newkids = ();
1969 }
1970
1971 if (exists $$self{Kids}) {
1972 my $arg = $$self{Kids}[0];
1973 push @newkids, $arg->ast($self, @_) if defined $arg;
1974 }
1975 if (@swap) {
1976 splice @{$newkids[-1][0]{Kids}}, -2, 0, @swap; # XXX WAG
1977 }
1978 push @newkids, $self->madness(')');
1979
1980 my $res = $self->newtype->new(Kids => [@newkids]);
1981 return $res;
1982}
1983
1984package PLXML::op_complement;
1985package PLXML::op_atan2;
1986package PLXML::op_sin;
1987package PLXML::op_cos;
1988package PLXML::op_rand;
1989package PLXML::op_srand;
1990package PLXML::op_exp;
1991package PLXML::op_log;
1992package PLXML::op_sqrt;
1993package PLXML::op_int;
1994package PLXML::op_hex;
1995package PLXML::op_oct;
1996package PLXML::op_abs;
1997package PLXML::op_length;
1998package PLXML::op_substr;
1999package PLXML::op_vec;
2000package PLXML::op_index;
2001package PLXML::op_rindex;
2002package PLXML::op_sprintf;
2003package PLXML::op_formline;
2004package PLXML::op_ord;
2005package PLXML::op_chr;
2006package PLXML::op_crypt;
2007package PLXML::op_ucfirst;
2008
2009sub ast {
2010 my $self = shift;
2011 return $self->PLXML::listop::ast(@_);
2012}
2013
2014package PLXML::op_lcfirst;
2015
2016sub ast {
2017 my $self = shift;
2018 return $self->PLXML::listop::ast(@_);
2019}
2020
2021package PLXML::op_uc;
2022
2023sub ast {
2024 my $self = shift;
2025 return $self->PLXML::listop::ast(@_);
2026}
2027
2028package PLXML::op_lc;
2029
2030sub ast {
2031 my $self = shift;
2032 return $self->PLXML::listop::ast(@_);
2033}
2034
2035package PLXML::op_quotemeta;
2036
2037sub ast {
2038 my $self = shift;
2039 return $self->PLXML::listop::ast(@_);
2040}
2041
2042package PLXML::op_rv2av;
2043
2044sub astnull {
2045 my $self = shift;
2046 return P5AST::op_rv2av->new(Kids => [$self->madness('$ @')]);
2047}
2048
2049sub ast {
2050 my $self = shift;
2051
2052 if (ref $$self{Kids}[0] eq 'PLXML::op_const' and $$self{mp}{'O'}) {
2053 return $self->madness('O');
2054 }
2055
2056 my @before;
2057 push @before, $self->madness('dx d (');
2058
2059 my @newkids;
2060 push @newkids, $self->madness('$ @ K');
2061 if (ref $$self{Kids}[0] ne "PLXML::op_gv") {
2062 push @newkids, $$self{Kids}[0]->ast();
2063 }
2064 my @after;
2065 push @after, $self->madness(') a');
2066 return $self->newtype->new(Kids => [@before, @newkids, @after]);
2067}
2068
2069package PLXML::op_aelemfast;
2070
2071sub ast {
2072 my $self = shift;
2073 return $self->madness('$');
2074}
2075
2076package PLXML::op_aelem;
2077
2078sub astnull {
2079 my $self = shift;
2080 my @newkids;
2081 push @newkids, $self->madness('dx d');
2082 for my $kid (@{$$self{Kids}}) {
2083 push @newkids, $kid->ast($self, @_);
2084 }
2085 splice @newkids, -1, 0, $self->madness('a [');
2086 push @newkids, $self->madness(']');
2087 return P5AST::op_aelem->new(Kids => [@newkids]);
2088}
2089
2090sub ast {
2091 my $self = shift;
2092
2093 my @before = $self->madness('dx d');
2094 my @newkids;
2095 for my $kid (@{$$self{Kids}}) {
2096 push @newkids, $kid->ast(@_);
2097 }
2098 splice @newkids, -1, 0, $self->madness('a [');
2099 push @newkids, $self->madness(']');
2100
2101 return $self->newtype->new(Kids => [@before, @newkids]);
2102}
2103
2104package PLXML::op_aslice;
2105
2106sub astnull {
2107 my $self = shift;
2108 my @newkids;
2109 push @newkids, $self->madness('[');
2110 for my $kid (@{$$self{Kids}}) {
2111 push @newkids, $kid->ast(@_);
2112 }
2113 unshift @newkids, pop @newkids;
2114 unshift @newkids, $self->madness('dx d');
2115 push @newkids, $self->madness(']');
2116 return P5AST::op_aslice->new(Kids => [@newkids]);
2117}
2118
2119sub ast {
2120 my $self = shift;
2121
2122 my @newkids;
2123 push @newkids, $self->madness('[');
2124 for my $kid (@{$$self{Kids}}) {
2125 push @newkids, $kid->ast(@_);
2126 }
2127 unshift @newkids, pop @newkids;
2128 unshift @newkids, $self->madness('dx d');
2129 push @newkids, $self->madness(']');
2130
2131 return $self->newtype->new(Kids => [@newkids]);
2132}
2133
2134package PLXML::op_each;
2135package PLXML::op_values;
2136package PLXML::op_keys;
2137package PLXML::op_delete;
2138package PLXML::op_exists;
2139package PLXML::op_rv2hv;
2140
2141sub astnull {
2142 my $self = shift;
2143 return P5AST::op_rv2hv->new(Kids => [$self->madness('$')]);
2144}
2145
2146sub ast {
2147 my $self = shift;
2148
2149 my @before;
2150 push @before, $self->madness('dx d (');
2151
2152 my @newkids;
2153 push @newkids, $self->madness('$ @ % K');
2154 if (ref $$self{Kids}[0] ne "PLXML::op_gv") {
2155 push @newkids, $$self{Kids}[0]->ast();
2156 }
2157 my @after;
2158 push @after, $self->madness(') a');
2159 return $self->newtype->new(Kids => [@before, @newkids, @after]);
2160}
2161
2162package PLXML::op_helem;
2163
2164sub astnull {
2165 my $self = shift;
2166 local $::curstate; # hash subscript potentially a lineseq
2167 local $::curenc = $::curenc;
2168
2169 my @newkids;
2170 push @newkids, $self->madness('dx d');
2171 for my $kid (@{$$self{Kids}}) {
2172 push @newkids, $kid->ast($self, @_);
2173 }
2174 splice @newkids, -1, 0, $self->madness('a {');
2175 push @newkids, $self->madness('}');
2176 return P5AST::op_helem->new(Kids => [@newkids]);
2177}
2178
2179sub ast {
2180 my $self = shift;
2181 local $::curstate; # hash subscript potentially a lineseq
2182 local $::curenc = $::curenc;
2183
2184 my @before = $self->madness('dx d');
2185 my @newkids;
2186 for my $kid (@{$$self{Kids}}) {
2187 push @newkids, $kid->ast($self, @_);
2188 }
2189 splice @newkids, -1, 0, $self->madness('a {');
2190 push @newkids, $self->madness('}');
2191
2192 return $self->newtype->new(Kids => [@before, @newkids]);
2193}
2194
2195
2196package PLXML::op_hslice;
2197
2198sub astnull {
2199 my $self = shift;
2200 my @newkids;
2201 push @newkids, $self->madness('{');
2202 for my $kid (@{$$self{Kids}}) {
2203 push @newkids, $kid->ast(@_);
2204 }
2205 unshift @newkids, pop @newkids;
2206 unshift @newkids, $self->madness('dx d');
2207 push @newkids, $self->madness('}');
2208 return P5AST::op_hslice->new(Kids => [@newkids]);
2209}
2210
2211sub ast {
2212 my $self = shift;
2213
2214 my @newkids;
2215 push @newkids, $self->madness('{');
2216 for my $kid (@{$$self{Kids}}) {
2217 push @newkids, $kid->ast(@_);
2218 }
2219 unshift @newkids, pop @newkids;
2220 unshift @newkids, $self->madness('dx d');
2221 push @newkids, $self->madness('}');
2222
2223 return $self->newtype->new(Kids => [@newkids]);
2224}
2225
2226package PLXML::op_unpack;
2227package PLXML::op_pack;
2228package PLXML::op_split;
2229
2230sub ast {
2231 my $self = shift;
2232 my $results = $self->SUPER::ast(@_);
2233 if (my @dest = $self->madness('R')) {
2234 return PLXML::op_aassign->newtype->new(Kids => [@dest, $self->madness('ox'), $results]);
2235 }
2236 return $results;
2237}
2238
2239package PLXML::op_join;
2240package PLXML::op_list;
2241
2242sub astnull {
2243 my $self = shift;
2244 my @newkids;
2245 my @retval;
2246 my @before;
2247 if (@retval = $self->madness('X')) {
2248 push @before, $self->madness('x o');
2249 return @before,@retval;
2250 }
2251 my @kids = @{$$self{Kids}};
2252 for my $kid (@kids) {
2253 next if ref $kid eq 'PLXML::op_pushmark';
2254 next if ref $kid eq 'PLXML::op_null' and
2255 defined $$kid{was} and $$kid{was} eq 'pushmark';
2256 push @newkids, $kid->ast($self, @_);
2257 }
2258
2259 my $x = "";
2260 my @newnewkids = ();
2261 push @newnewkids, $self->madness('dx d (');
2262 push @newnewkids, @newkids;
2263 push @newnewkids, $self->madness(') :');
2264 return P5AST::op_list->new(Kids => [@newnewkids]);
2265}
2266
2267sub ast {
2268 my $self = shift;
2269
2270 my @retval;
2271 my @before;
2272 if (@retval = $self->madness('X')) {
2273 push @before, $self->madness('o');
2274 return $self->newtype->new(Kids => [@before,@retval]);
2275 }
2276 push @retval, $self->madness('dx d (');
2277
2278 my @newkids;
2279 for my $kid (@{$$self{Kids}}) {
2280 push @newkids, $kid->ast($self, @_);
2281 }
2282 my $x = "";
2283 my @newnewkids = ();
2284 push @newnewkids, @newkids;
2285 @newkids = @newnewkids;
2286 push @retval, @newkids;
2287 push @retval, $self->madness(') :');
2288 return $self->newtype->new(Kids => [@retval]);
2289}
2290
2291package PLXML::op_lslice;
2292
2293sub ast {
2294 my $self = shift;
2295 my @newkids;
2296
2297 if ($$self{mp}{q}) {
2298 push @newkids, $self->madness('q = Q');
2299 }
2300 elsif ($$self{mp}{x}) {
2301 push @newkids, $self->madness('x');
2302 }
2303 else {
2304 push @newkids, $self->madness('(');
2305 my $list = $$self{Kids}[1];
2306 push @newkids, $list->ast($self, @_);
2307 push @newkids, $self->madness(')');
2308 }
2309
2310 push @newkids, $self->madness('[');
2311
2312 my $slice = $$self{Kids}[0];
2313 push @newkids, $slice->ast($self, @_);
2314 push @newkids, $self->madness(']');
2315
2316 return $self->newtype->new(Kids => [@newkids]);
2317}
2318
2319package PLXML::op_anonlist;
2320package PLXML::op_anonhash;
2321package PLXML::op_splice;
2322package PLXML::op_push;
2323package PLXML::op_pop;
2324package PLXML::op_shift;
2325package PLXML::op_unshift;
2326package PLXML::op_sort;
2327package PLXML::op_reverse;
2328
2329sub astnull {
2330 my $self = shift;
2331 $self->PLXML::listop::ast(@_);
2332}
2333
2334package PLXML::op_grepstart;
2335package PLXML::op_grepwhile;
2336package PLXML::op_mapstart;
2337package PLXML::op_mapwhile;
2338package PLXML::op_range;
2339
2340sub ast {
2341 my $self = shift;
2342 return $self->PLXML::binop::ast(@_);
2343}
2344
2345package PLXML::op_flip;
2346package PLXML::op_flop;
2347package PLXML::op_and;
2348
2349sub astnull {
2350 my $self = shift;
2351 my @newkids;
2352 my @first = $self->madness('1');
2353 my @second = $self->madness('2');
2354 my @stuff = $$self{Kids}[0]->ast();
2355 if (my @I = $self->madness('I')) {
2356 if (@second) {
2357 push @newkids, @I;
2358 push @newkids, $self->madness('(');
2359 push @newkids, @stuff;
2360 push @newkids, $self->madness(')');
2361 push @newkids, @second;
2362 }
2363 else {
2364 push @newkids, @I;
2365 push @newkids, $self->madness('(');
2366 push @newkids, @first;
2367 push @newkids, $self->madness(')');
2368 push @newkids, @stuff;
2369 }
2370 }
2371 elsif (my @i = $self->madness('i')) {
2372 if (@second) {
2373 push @newkids, @second;
2374 push @newkids, @i;
2375 push @newkids, @stuff;
2376 }
2377 else {
2378 push @newkids, @stuff;
2379 push @newkids, @i;
2380 push @newkids, @first;
2381 }
2382 }
2383 elsif (my @o = $self->madness('o')) {
2384 if (@second) {
2385 push @newkids, @stuff;
2386 push @newkids, @o;
2387 push @newkids, @second;
2388 }
2389 else {
2390 push @newkids, @first;
2391 push @newkids, @o;
2392 push @newkids, @stuff;
2393 }
2394 }
2395 return P5AST::op_and->new(Kids => [@newkids]);
2396}
2397
2398package PLXML::op_or;
2399
2400sub astnull {
2401 my $self = shift;
2402 my @newkids;
2403 my @first = $self->madness('1');
2404 my @second = $self->madness('2');
2405 my @i = $self->madness('i');
2406 my @stuff = $$self{Kids}[0]->ast();
2407 if (@second) {
2408 if (@i) {
2409 push @newkids, @second;
2410 push @newkids, $self->madness('i');
2411 push @newkids, @stuff;
2412 }
2413 else {
2414 push @newkids, @stuff;
2415 push @newkids, $self->madness('o');
2416 push @newkids, @second;
2417 }
2418 }
2419 else {
2420 if (@i) {
2421 push @newkids, @stuff;
2422 push @newkids, $self->madness('i');
2423 push @newkids, @first;
2424 }
2425 else {
2426 push @newkids, @first;
2427 push @newkids, $self->madness('o');
2428 push @newkids, @stuff;
2429 }
2430 }
2431 return "P5AST::op_$$self{was}"->new(Kids => [@newkids]);
2432}
2433
2434
2435package PLXML::op_xor;
2436package PLXML::op_cond_expr;
2437package PLXML::op_andassign;
2438package PLXML::op_orassign;
2439package PLXML::op_method;
2440package PLXML::op_entersub;
2441
2442sub ast {
2443 my $self = shift;
2444
2445 if ($$self{mp}{q}) {
2446 return $self->madness('q = Q');
2447 }
2448 if ($$self{mp}{X}) { # <FH> override?
2449 return $self->madness('X');
2450 }
2451 if ($$self{mp}{A}) {
2452 return $self->astmethod(@_);
2453 }
2454 if ($$self{mp}{a}) {
2455 return $self->astarrow(@_);
2456 }
2457
2458 my @retval;
2459
2460 my @newkids;
2461 my @kids = @{$$self{Kids}};
2462 if (@kids == 1 and ref $kids[0] eq 'PLXML::op_null' and $kids[0]{was} =~ /list/) {
2463 @kids = @{$kids[0]{Kids}};
2464 }
2465 my $dest = pop @kids;
2466 my @dest = $dest->ast($self, @_);
2467
2468 if (ref($dest) =~ /method/) {
2469 my $invocant = shift @kids;
2470 $invocant = shift @kids if ref($invocant) eq 'PLXML::op_pushmark';
2471 my @invocant = $invocant->ast($self, @_);
2472 push @retval, @dest;
2473 push @retval, @invocant;
2474 }
2475 elsif (exists $$self{mp}{o} and $$self{mp}{o} eq 'do') {
2476 push @retval, $self->madness('o');
2477 push @retval, @dest;
2478 }
2479 else {
2480 push @retval, $self->madness('o');
2481 push @retval, @dest;
2482 }
2483 while (@kids) {
2484 my $kid = shift(@kids);
2485 push @newkids, $kid->ast($self, @_);
2486 }
2487
2488 push @retval, $self->madness('(');
2489 push @retval, @newkids;
2490 push @retval, $self->madness(')');
2491 return $self->newtype->new(Kids => [@retval]);
2492}
2493
2494sub astmethod {
2495 my $self = shift;
2496 my @newkids;
2497 my @kids;
2498 for my $kid (@{$$self{Kids}}) {
2499 next if ref $kid eq 'PLXML::op_pushmark';
2500 next if ref $kid eq 'PLXML::op_null' and
2501 defined $$kid{was} and $$kid{was} eq 'pushmark';
2502 push @kids, $kid;
2503 }
2504 my @invocant;
2505 if ($$self{flags} =~ /\bSTACKED\b/) {
2506 push @invocant, shift(@kids)->ast($self, @_);
2507 }
2508 for my $kid (@kids) {
2509 push @newkids, $kid->ast($self, @_);
2510 }
2511 my $dest = pop(@newkids);
2512 if (ref $dest eq 'PLXML::op_rv2cv' and $$self{flags} =~ /\bMOD\b/) {
2513 $dest = pop(@newkids);
2514 }
2515 my $x = "";
2516 my @retval;
2517 push @retval, @invocant;
2518 push @retval, $self->madness('A');
2519 push @retval, $dest;
2520 push @retval, $self->madness('(');
2521 push @retval, @newkids;
2522 push @retval, $self->madness(')');
2523 return $self->newtype->new(Kids => [@retval]);
2524}
2525
2526sub astarrow {
2527 my $self = shift;
2528 my @newkids;
2529 my @retval;
2530 my @kids = @{$$self{Kids}};
2531 if (@kids == 1 and ref $kids[0] eq 'PLXML::op_null' and $kids[0]{was} =~ /list/) {
2532 @kids = @{$kids[0]{Kids}};
2533 }
2534 while (@kids > 1) {
2535 my $kid = shift(@kids);
2536 push @newkids, $kid->ast($self, @_);
2537 }
2538 my @dest = $kids[0]->ast($self, @_);
2539 my $x = "";
2540 push @retval, @dest;
2541 push @retval, $self->madness('a');
2542 push @retval, $self->madness('(');
2543 push @retval, @newkids;
2544 push @retval, $self->madness(')');
2545 return $self->newtype->new(Kids => [@retval]);
2546}
2547
2548package PLXML::op_leavesub;
2549
2550sub ast {
2551 my $self = shift;
2552 if (ref $$self{Kids}[0] eq "PLXML::op_null") {
2553 return $$self{Kids}[0]->ast(@_);
2554 }
2555 return $$self{Kids}[0]->blockast($self, @_);
2556}
2557
2558package PLXML::op_leavesublv;
2559
2560sub ast {
2561 my $self = shift;
2562
2563 return $$self{Kids}[0]->blockast($self, @_);
2564}
2565
2566package PLXML::op_caller;
2567package PLXML::op_warn;
2568package PLXML::op_die;
2569package PLXML::op_reset;
2570package PLXML::op_lineseq;
2571
2572sub lineseq {
2573 my $self = shift;
2574 my @kids = @{$$self{Kids}};
2575 local $::curstate = 0; # (probably redundant, but that's okay)
2576 local $::prevstate = 0;
2577 local $::curenc = $::curenc;
2578 my @retval;
2579 my @newstuff;
2580 my $newprev;
2581 while (@kids) {
2582 my $kid = shift @kids;
2583 my $thing = $kid->ast($self, @_);
2584 next unless defined $thing;
2585 if ($::curstate ne $::prevstate) {
2586 if ($::prevstate) {
2587 push @newstuff, $::prevstate->madness(';');
2588 push @{$newprev->{Kids}}, @newstuff if $newprev;
2589 @newstuff = ();
2590 }
2591 $::prevstate = $::curstate;
2592 $newprev = $thing;
2593 push @retval, $thing;
2594 }
2595 elsif ($::prevstate) {
2596 push @newstuff, $thing;
2597 }
2598 else {
2599 push @retval, $thing;
2600 }
2601 }
2602 if ($::prevstate) {
2603 push @newstuff, $::prevstate->madness(';');
2604 push @{$newprev->{Kids}}, @newstuff if $newprev;
2605 @newstuff = ();
2606 $::prevstate = 0;
2607 }
2608 return @retval;
2609}
2610
2611sub blockast {
2612 my $self = shift;
2613 local $::curstate;
2614
2615 my @retval;
2616 push @retval, $self->madness('{');
2617
2618 my @newkids = $self->PLXML::op_lineseq::lineseq(@_);
2619 push @retval, @newkids;
2620
2621 push @retval, $self->madness('; }');
2622 return $self->newtype->new(Kids => [@retval]);
2623}
2624
2625package PLXML::op_nextstate;
2626
2627sub newtype { return "P5AST::statement" }
2628
2629sub astnull {
2630 my $self = shift;
2631 my @newkids;
2632 push @newkids, $self->madness('L');
2633 $::curstate = $self;
2634 return P5AST::statement->new(Kids => [@newkids]);
2635}
2636
2637sub ast {
2638 my $self = shift;
2639
2640 my @newkids;
2641 push @newkids, $self->madness('L');
2642 $::curstate = $self;
2643 return $self->newtype->new(Kids => [@newkids]);
2644}
2645
2646
2647package PLXML::op_dbstate;
2648package PLXML::op_unstack;
2649package PLXML::op_enter;
2650
2651sub ast { () }
2652
2653package PLXML::op_leave;
2654
2655sub astnull {
2656 ast(@_);
2657}
2658
2659sub ast {
2660 my $self = shift;
2661
2662 my $mad = $$self{mp}{FIRST} || "unknown";
2663
2664 my @retval;
2665 if ($mad eq 'w') {
2666 my @newkids;
2667 my @tmpkids;
2668 push @tmpkids, $self->{Kids};
2669 my $anddo = $$self{Kids}[-1]{Kids}[0]{Kids};
2670 eval { push @newkids, $anddo->[1]->ast($self,@_); };
2671 push @newkids, "[[[NOANDDO]]]" if $@;
2672 push @newkids, $self->madness('w');
2673 push @newkids, $anddo->[0]->ast($self,@_);
2674
2675 return $self->newtype->new(Kids => [@newkids]);
2676 }
2677
2678 local $::curstate;
2679 push @retval, $self->madness('o {');
2680
2681 my @newkids = $self->PLXML::op_lineseq::lineseq(@_);
2682 push @retval, @newkids;
2683 push @retval, $self->madness(q/; }/);
2684 my $retval = $self->newtype->new(Kids => [@retval]);
2685
2686 if ($$self{mp}{C}) {
2687 my @before;
2688 my @after;
2689 push @before, $self->madness('I ( C )');
2690 if ($$self{mp}{t}) {
2691 push @before, $self->madness('t');
2692 }
2693 elsif ($$self{mp}{e}) {
2694 push @after, $self->madness('e');
2695 }
2696 return P5AST::op_cond->new(Kids => [@before, $retval, @after]);
2697 }
2698 else {
2699 return $retval;
2700 }
2701}
2702
2703package PLXML::op_scope;
2704
2705sub ast {
2706 my $self = shift;
2707 local $::curstate;
2708
2709 my @newkids;
2710 push @newkids, $self->madness('o');
2711
2712 push @newkids, $self->madness('{');
2713 push @newkids, $self->PLXML::op_lineseq::lineseq(@_);
2714 push @newkids, $self->madness('; }');
2715
2716 my @folded = $self->madness('C');
2717 if (@folded) {
2718 my @t = $self->madness('t');
2719 my @e = $self->madness('e');
2720 if (@e) {
2721 return $self->newtype->new(
2722 Kids => [
2723 $self->madness('I ('),
2724 @folded,
2725 $self->madness(')'),
2726 $self->newtype->new(Kids => [@newkids]),
2727 @e
2728 ] );
2729 }
2730 else {
2731 return $self->newtype->new(
2732 Kids => [
2733 $self->madness('I ('),
2734 @folded,
2735 $self->madness(')'),
2736 @t,
2737 $self->newtype->new(Kids => [@newkids])
2738 ] );
2739 }
2740 }
2741 return $self->newtype->new(Kids => [@newkids]);
2742}
2743
2744package PLXML::op_enteriter;
2745
2746sub ast {
2747 my $self = shift;
2748 my (undef,$range,$var) = @{$self->{Kids}};
2749 my @retval;
2750 push @retval, $self->madness('v');
2751 if (!@retval and defined $var) {
2752 push @retval, $var->ast($self,@_);
2753 }
2754 else {
2755 push @retval, '';
2756 }
2757 if (ref $range eq 'PLXML::op_null' and $$self{flags} =~ /STACKED/) {
2758 my (undef,$min,$max) = @{$range->{Kids}};
2759 push @retval, $min->ast($self,@_);
2760 if (defined $max) {
2761 if (exists $$range{mp}{O}) { # deeply buried .. operator
2762 PLXML::prepreproc($$range{mp}{O});
2763 push @retval,
2764 $$range{mp}{'O'}{Kids}[0]{Kids}[0]{Kids}[0]{Kids}[0]->madness('o')
2765 }
2766 else {
2767 push @retval, '..'; # XXX missing whitespace
2768 }
2769 push @retval, $max->ast($self,@_);
2770 }
2771 }
2772 else {
2773 push @retval, $range->ast($self,@_);
2774 }
2775 return $self->newtype->new(Kids => [@retval]);
2776}
2777
2778package PLXML::op_iter;
2779package PLXML::op_enterloop;
2780
2781sub ast {
2782}
2783
2784package PLXML::op_leaveloop;
2785
2786sub ast {
2787 my $self = shift;
2788
2789 my @retval;
2790 my @newkids;
2791 my $enterloop = $$self{Kids}[0];
2792 my $nextthing = $$self{Kids}[1];
2793
2794 if ($$self{mp}{W}) {
2795 push @retval, $self->madness('L');
2796 push @newkids, $self->madness('W d');
2797
2798 if (ref $enterloop eq 'PLXML::op_enteriter') {
2799 my ($var,@rest) = @{$enterloop->ast($self,@_)->{Kids}};
2800 push @newkids, $var if $var;
2801 push @newkids, $self->madness('q ( x = Q');
2802 push @newkids, @rest;
2803 }
2804 else {
2805 push @newkids, $self->madness('(');
2806 push @newkids, $enterloop->ast($self,@_);
2807 }
2808 }
2809 my $andor;
2810
2811 if (ref $nextthing eq 'PLXML::op_null') {
2812 if ($$nextthing{mp}{'1'}) {
2813 push @newkids, $nextthing->madness('1');
2814 push @newkids, $self->madness(')');
2815 push @newkids, $$nextthing{Kids}[0]->blockast($self,@_);
2816 }
2817 elsif ($$nextthing{mp}{'2'}) {
2818 push @newkids, $$nextthing{Kids}[0]->ast($self,@_);
2819 push @newkids, $self->madness(')');
2820 push @newkids, $$nextthing{mp}{'2'}->blockast($self,@_);
2821 }
2822 elsif ($$nextthing{mp}{'U'}) {
2823 push @newkids, $nextthing->ast($self,@_);
2824 }
2825 else {
2826 # bypass the op_null
2827 $andor = $nextthing->{Kids}[0];
2828 eval {
2829 push @newkids, $$andor{Kids}[0]->ast($self, @_);
2830 };
2831 push @newkids, $self->madness(')');
2832 eval {
2833 push @newkids, $$andor{Kids}[1]->blockast($self, @_);
2834 };
2835 }
2836 }
2837 else {
2838 $andor = $nextthing;
2839 push @newkids, $nextthing->madness('O');
2840 push @newkids, $self->madness(')');
2841 push @newkids, $nextthing->blockast($self, @_);
2842 }
2843 if ($$self{mp}{w}) {
2844 push @newkids, $self->madness('w');
2845 push @newkids, $enterloop->ast($self,@_);
2846 }
2847
2848 push @retval, @newkids;
2849
2850 return $self->newtype->new(Kids => [@retval]);
2851}
2852
2853package PLXML::op_return;
2854package PLXML::op_last;
2855package PLXML::op_next;
2856package PLXML::op_redo;
2857package PLXML::op_dump;
2858package PLXML::op_goto;
2859package PLXML::op_exit;
2860package PLXML::op_open;
2861package PLXML::op_close;
2862package PLXML::op_pipe_op;
2863package PLXML::op_fileno;
2864package PLXML::op_umask;
2865package PLXML::op_binmode;
2866package PLXML::op_tie;
2867package PLXML::op_untie;
2868package PLXML::op_tied;
2869package PLXML::op_dbmopen;
2870package PLXML::op_dbmclose;
2871package PLXML::op_sselect;
2872package PLXML::op_select;
2873package PLXML::op_getc;
2874package PLXML::op_read;
2875package PLXML::op_enterwrite;
2876package PLXML::op_leavewrite;
2877package PLXML::op_prtf;
2878package PLXML::op_print;
2879package PLXML::op_sysopen;
2880package PLXML::op_sysseek;
2881package PLXML::op_sysread;
2882package PLXML::op_syswrite;
2883package PLXML::op_send;
2884package PLXML::op_recv;
2885package PLXML::op_eof;
2886package PLXML::op_tell;
2887package PLXML::op_seek;
2888package PLXML::op_truncate;
2889package PLXML::op_fcntl;
2890package PLXML::op_ioctl;
2891package PLXML::op_flock;
2892package PLXML::op_socket;
2893package PLXML::op_sockpair;
2894package PLXML::op_bind;
2895package PLXML::op_connect;
2896package PLXML::op_listen;
2897package PLXML::op_accept;
2898package PLXML::op_shutdown;
2899package PLXML::op_gsockopt;
2900package PLXML::op_ssockopt;
2901package PLXML::op_getsockname;
2902package PLXML::op_getpeername;
2903package PLXML::op_lstat;
2904package PLXML::op_stat;
2905package PLXML::op_ftrread;
2906package PLXML::op_ftrwrite;
2907package PLXML::op_ftrexec;
2908package PLXML::op_fteread;
2909package PLXML::op_ftewrite;
2910package PLXML::op_fteexec;
2911package PLXML::op_ftis;
2912package PLXML::op_fteowned;
2913package PLXML::op_ftrowned;
2914package PLXML::op_ftzero;
2915package PLXML::op_ftsize;
2916package PLXML::op_ftmtime;
2917package PLXML::op_ftatime;
2918package PLXML::op_ftctime;
2919package PLXML::op_ftsock;
2920package PLXML::op_ftchr;
2921package PLXML::op_ftblk;
2922package PLXML::op_ftfile;
2923package PLXML::op_ftdir;
2924package PLXML::op_ftpipe;
2925package PLXML::op_ftlink;
2926package PLXML::op_ftsuid;
2927package PLXML::op_ftsgid;
2928package PLXML::op_ftsvtx;
2929package PLXML::op_fttty;
2930package PLXML::op_fttext;
2931package PLXML::op_ftbinary;
2932package PLXML::op_chdir;
2933package PLXML::op_chown;
2934package PLXML::op_chroot;
2935package PLXML::op_unlink;
2936package PLXML::op_chmod;
2937package PLXML::op_utime;
2938package PLXML::op_rename;
2939package PLXML::op_link;
2940package PLXML::op_symlink;
2941package PLXML::op_readlink;
2942package PLXML::op_mkdir;
2943package PLXML::op_rmdir;
2944package PLXML::op_open_dir;
2945package PLXML::op_readdir;
2946package PLXML::op_telldir;
2947package PLXML::op_seekdir;
2948package PLXML::op_rewinddir;
2949package PLXML::op_closedir;
2950package PLXML::op_fork;
2951package PLXML::op_wait;
2952package PLXML::op_waitpid;
2953package PLXML::op_system;
2954package PLXML::op_exec;
2955package PLXML::op_kill;
2956package PLXML::op_getppid;
2957package PLXML::op_getpgrp;
2958package PLXML::op_setpgrp;
2959package PLXML::op_getpriority;
2960package PLXML::op_setpriority;
2961package PLXML::op_time;
2962package PLXML::op_tms;
2963package PLXML::op_localtime;
2964package PLXML::op_gmtime;
2965package PLXML::op_alarm;
2966package PLXML::op_sleep;
2967package PLXML::op_shmget;
2968package PLXML::op_shmctl;
2969package PLXML::op_shmread;
2970package PLXML::op_shmwrite;
2971package PLXML::op_msgget;
2972package PLXML::op_msgctl;
2973package PLXML::op_msgsnd;
2974package PLXML::op_msgrcv;
2975package PLXML::op_semget;
2976package PLXML::op_semctl;
2977package PLXML::op_semop;
2978package PLXML::op_require;
2979package PLXML::op_dofile;
2980package PLXML::op_entereval;
2981
2982sub ast {
2983 my $self = shift;
2984 local $::curstate; # eval {} has own statement sequence
2985 return $self->SUPER::ast(@_);
2986}
2987
2988package PLXML::op_leaveeval;
2989package PLXML::op_entertry;
2990package PLXML::op_leavetry;
2991
2992sub ast {
2993 my $self = shift;
2994
2995 return $self->PLXML::op_leave::ast(@_);
2996}
2997
2998package PLXML::op_ghbyname;
2999package PLXML::op_ghbyaddr;
3000package PLXML::op_ghostent;
3001package PLXML::op_gnbyname;
3002package PLXML::op_gnbyaddr;
3003package PLXML::op_gnetent;
3004package PLXML::op_gpbyname;
3005package PLXML::op_gpbynumber;
3006package PLXML::op_gprotoent;
3007package PLXML::op_gsbyname;
3008package PLXML::op_gsbyport;
3009package PLXML::op_gservent;
3010package PLXML::op_shostent;
3011package PLXML::op_snetent;
3012package PLXML::op_sprotoent;
3013package PLXML::op_sservent;
3014package PLXML::op_ehostent;
3015package PLXML::op_enetent;
3016package PLXML::op_eprotoent;
3017package PLXML::op_eservent;
3018package PLXML::op_gpwnam;
3019package PLXML::op_gpwuid;
3020package PLXML::op_gpwent;
3021package PLXML::op_spwent;
3022package PLXML::op_epwent;
3023package PLXML::op_ggrnam;
3024package PLXML::op_ggrgid;
3025package PLXML::op_ggrent;
3026package PLXML::op_sgrent;
3027package PLXML::op_egrent;
3028package PLXML::op_getlogin;
3029package PLXML::op_syscall;
3030package PLXML::op_lock;
3031package PLXML::op_threadsv;
3032package PLXML::op_setstate;
3033package PLXML::op_method_named;
3034
3035sub ast {
3036 my $self = shift;
3037 return $self->madness('O');
3038}
3039
3040package PLXML::op_dor;
3041
3042sub astnull {
3043 my $self = shift;
3044 $self->PLXML::op_or::astnull(@_);
3045}
3046
3047package PLXML::op_dorassign;
3048package PLXML::op_custom;
3049
Unnamed repository; edit this file to name it for gitweb.