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