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