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