This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
https://perl5.git.perl.org / perl5.git / blame
? search:
summary | shortlog | log | commit | commitdiff | tree
blob | blame (incremental) | history | HEAD
perldelta updates for 6728836, d60d201, 82f9620, 7878705
[perl5.git] / mad / Nomad.pm
CommitLineData
82a7479c 1package Nomad;
6a28abbc
NC		 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
NC		 13
14use P5AST;
15use P5re;
16
6a28abbc
NC		 17my $deinterpolate;
18
82a7479c
GG		 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
GG		 53 # Finally, walk AST to produce new program.
54
55 my $text = $ast->p5text(); # returns encoded, must output raw
56 return $text;
57}
6a28abbc
NC		 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
NC		 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
NC		 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
NC		 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
GG		 523 $k .= 'x' while exists $hash{$k};
524 $lastthing = $k;
6a28abbc
NC		 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
NC		 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
NC		 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
NC		 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
NC		 674 return P5AST::listop->new(Kids => [@before,@retval]);
675 }
676
d5d3e0f0 677 push @retval, $self->madness('o d ( [ {');
6a28abbc
NC		 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
NC		 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
NC		 948 }
949 elsif ($module->uni eq 'utf8') {
950 if ($$self{mp}{o} eq 'no') {
82a7479c 951 $::curenc = Nomad::encnum('iso-8859-1');
6a28abbc
NC		 952 }
953 else {
82a7479c 954 $::curenc = Nomad::encnum('utf-8');
6a28abbc
NC		 955 }
956 }
957 elsif ($module->uni eq 'encoding') {
958 if ($$self{mp}{o} eq 'no') {
82a7479c 959 $::curenc = Nomad::encnum('iso-8859-1');
6a28abbc
NC		 960 }
961 else {
82a7479c 962 $::curenc = Nomad::encnum(eval $args[0]->p5text); # XXX bletch
6a28abbc
NC		 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 }
b3f5cf18
GG		 1686 # remove the fake '\n' if /e and '#' in replacement.
1687 if (@mods and $mods[0] =~ m/e/ and ($self->madness('R'))[0]->uni =~ m/#/) {
1688 unshift @rlast, bless {}, 'chomp'; # hack to remove '\n'
1689 }
6a28abbc
NC		 1690 push @newkids, $bits->{repl}, @rlast, @mods;
1691
1692 my $retval = $self->newtype->new(Kids => [@newkids]);
1693 if ($deinterpolate) {
1694 my $p5re = $retval->p5text();
1695 $retval->{P5re} = P5re::qrparse($p5re);
1696 }
1697 return $retval;
1698}
1699
1700package PLXML::op_substcont;
1701package PLXML::op_trans;
1702
1703sub ast {
1704 my $self = shift;
1705
1706# my $bits = $self->fetchbits($$self{flags},@_);
1707#
1708 my @newkids;
1709 my @lfirst = $self->madness('q');
1710 my @llast = $self->madness('Q');
1711 push @newkids,
1712 @lfirst,
1713 $self->madness('E'),
1714 @llast;
1715 my @rfirst = $self->madness('z');
1716 my @repl = $self->madness('R');
1717 my @rlast = $self->madness('Z');
1718 my @mods = $self->madness('m');
1719 if ($rfirst[-1]->uni ne $llast[-1]->uni) {
1720 push @newkids, @rfirst;
1721 }
1722
1723 push @newkids, @repl, @rlast, @mods;
1724
1725 my $res = $self->newtype->new(Kids => [@newkids]);
1726 return $res;
1727}
1728
1729package PLXML::op_sassign;
1730
1731sub ast {
1732 my $self = shift;
1733 my @newkids;
1734
1735 my $right = $$self{Kids}[1];
1736 eval { push @newkids, $right->ast($self, @_); };
1737
1738 push @newkids, $self->madness('o');
1739
1740 my $left = $$self{Kids}[0];
1741 push @newkids, $left->ast($self, @_);
1742
1743 return $self->newtype->new(Kids => [@newkids]);
1744}
1745
1746package PLXML::op_aassign;
1747
1748sub astnull { ast(@_) }
1749
1750sub ast {
1751 my $self = shift;
1752 my @newkids;
1753
1754 my $right = $$self{Kids}[1];
1755 push @newkids, $right->ast($self, @_);
1756
1757 push @newkids, $self->madness('o');
1758
1759 my $left = $$self{Kids}[0];
1760 push @newkids, $left->ast($self, @_);
1761
1762 return $self->newtype->new(Kids => [@newkids]);
1763}
1764
1765package PLXML::op_chop;
1766package PLXML::op_schop;
1767package PLXML::op_chomp;
1768package PLXML::op_schomp;
1769package PLXML::op_defined;
1770package PLXML::op_undef;
1771package PLXML::op_study;
1772package PLXML::op_pos;
1773package PLXML::op_preinc;
1774
1775sub ast {
1776 my $self = shift;
1777 if ($$self{targ}) { # stealth post inc or dec
1778 return $self->PLXML::op_postinc::ast(@_);
1779 }
1780 return $self->SUPER::ast(@_);
1781}
1782
1783package PLXML::op_i_preinc;
1784
1785sub ast { my $self = shift; $self->PLXML::op_preinc::ast(@_); }
1786
1787package PLXML::op_predec;
1788
1789sub ast { my $self = shift; $self->PLXML::op_preinc::ast(@_); }
1790
1791package PLXML::op_i_predec;
1792
1793sub ast { my $self = shift; $self->PLXML::op_preinc::ast(@_); }
1794
1795package PLXML::op_postinc;
1796
1797sub ast {
1798 my $self = shift;
1799 my @newkids;
1800
1801 if (exists $$self{Kids}) {
1802 my $arg = $$self{Kids}[0];
1803 push @newkids, $arg->ast($self, @_) if defined $arg;
1804 }
1805 push @newkids, $self->madness('o');
1806
1807 my $res = $self->newtype->new(Kids => [@newkids]);
1808 return $res;
1809}
1810
1811package PLXML::op_i_postinc;
1812
1813sub ast { my $self = shift; $self->PLXML::op_postinc::ast(@_); }
1814
1815package PLXML::op_postdec;
1816
1817sub ast { my $self = shift; $self->PLXML::op_postinc::ast(@_); }
1818
1819package PLXML::op_i_postdec;
1820
1821sub ast { my $self = shift; $self->PLXML::op_postinc::ast(@_); }
1822
1823package PLXML::op_pow;
1824package PLXML::op_multiply;
1825package PLXML::op_i_multiply;
1826package PLXML::op_divide;
1827package PLXML::op_i_divide;
1828package PLXML::op_modulo;
1829package PLXML::op_i_modulo;
1830package PLXML::op_repeat;
1831
1832sub ast {
1833 my $self = shift;
1834 return $self->SUPER::ast(@_)
1835 unless exists $$self{private} and $$self{private} =~ /DOLIST/;
1836
1837 my $newself = $$self{Kids}[0]->ast($self,@_);
1838 splice @{$newself->{Kids}}, -1, 0, $self->madness('o');
1839
1840 return bless $newself, $self->newtype; # rebless the op_null
1841}
1842
1843package PLXML::op_add;
1844package PLXML::op_i_add;
1845package PLXML::op_subtract;
1846package PLXML::op_i_subtract;
1847package PLXML::op_concat;
1848
1849sub astnull {
1850 my $self = shift;
1851 my @newkids;
1852
6a28abbc
NC		 1853 my @after;
1854 my $left = $$self{Kids}[0];
1855 push @newkids, $left->ast($self, @_);
1856
1857 push @newkids, $self->madness('o');
1858
1859 my $right = $$self{Kids}[1];
1860 push @newkids, $right->ast($self, @_);
1861 return P5AST::op_concat->new(Kids => [@newkids]);
1862}
1863
1864sub ast {
1865 my $self = shift;
1866 my $parent = $_[0];
1867 my @newkids;
1868
6a28abbc
NC		 1869 my @after;
1870 my $left = $$self{Kids}[0];
1871 push @newkids, $left->ast($self, @_);
1872
1873 push @newkids, $self->madness('o');
1874
1875 my $right = $$self{Kids}[1];
1876 push @newkids, $right->ast($self, @_);
1877
1b438339 1878 return $self->newtype->new(Kids => [@newkids, @after]);
6a28abbc
NC		 1879}
1880
1881package PLXML::op_stringify;
1882
1883sub astnull {
1884 ast(@_);
1885}
1886
1887sub ast {
1888 my $self = shift;
1889 my @newkids;
1890 my @front = $self->madness('q (');
1891 my @back = $self->madness(') Q');
1892 my @M = $self->madness('M');
1893 if (@M) {
1894 push @newkids, $M[0], $self->madness('o');
1895 }
1896 push @newkids, @front;
1897 for my $kid (@{$$self{Kids}}) {
1898 push @newkids, $kid->ast($self, @_);
1899 }
1900 push @newkids, @back;
1901 return P5AST::op_stringify->new(Kids => [@newkids]);
1902}
1903
1904package PLXML::op_left_shift;
1905package PLXML::op_right_shift;
1906package PLXML::op_lt;
1907package PLXML::op_i_lt;
1908package PLXML::op_gt;
1909package PLXML::op_i_gt;
1910package PLXML::op_le;
1911package PLXML::op_i_le;
1912package PLXML::op_ge;
1913package PLXML::op_i_ge;
1914package PLXML::op_eq;
1915package PLXML::op_i_eq;
1916package PLXML::op_ne;
1917package PLXML::op_i_ne;
1918package PLXML::op_ncmp;
1919package PLXML::op_i_ncmp;
1920package PLXML::op_slt;
1921package PLXML::op_sgt;
1922package PLXML::op_sle;
1923package PLXML::op_sge;
1924package PLXML::op_seq;
1925package PLXML::op_sne;
1926package PLXML::op_scmp;
1927package PLXML::op_bit_and;
1928package PLXML::op_bit_xor;
1929package PLXML::op_bit_or;
1930package PLXML::op_negate;
1931package PLXML::op_i_negate;
1932package PLXML::op_not;
1933
1934sub ast {
1935 my $self = shift;
1936 my @newkids = $self->madness('o (');
1937 my @swap;
1938 if (@newkids and $newkids[-1]->uni eq '!~') {
1939 @swap = @newkids;
1940 @newkids = ();
1941 }
1942
1943 if (exists $$self{Kids}) {
1944 my $arg = $$self{Kids}[0];
1945 push @newkids, $arg->ast($self, @_) if defined $arg;
1946 }
1947 if (@swap) {
1948 splice @{$newkids[-1][0]{Kids}}, -2, 0, @swap; # XXX WAG
1949 }
1950 push @newkids, $self->madness(')');
1951
1952 my $res = $self->newtype->new(Kids => [@newkids]);
1953 return $res;
1954}
1955
1956package PLXML::op_complement;
1957package PLXML::op_atan2;
1958package PLXML::op_sin;
1959package PLXML::op_cos;
1960package PLXML::op_rand;
1961package PLXML::op_srand;
1962package PLXML::op_exp;
1963package PLXML::op_log;
1964package PLXML::op_sqrt;
1965package PLXML::op_int;
1966package PLXML::op_hex;
1967package PLXML::op_oct;
1968package PLXML::op_abs;
1969package PLXML::op_length;
1970package PLXML::op_substr;
1971package PLXML::op_vec;
1972package PLXML::op_index;
1973package PLXML::op_rindex;
1974package PLXML::op_sprintf;
1975package PLXML::op_formline;
1976package PLXML::op_ord;
1977package PLXML::op_chr;
1978package PLXML::op_crypt;
1979package PLXML::op_ucfirst;
1980
1981sub ast {
1982 my $self = shift;
1983 return $self->PLXML::listop::ast(@_);
1984}
1985
1986package PLXML::op_lcfirst;
1987
1988sub ast {
1989 my $self = shift;
1990 return $self->PLXML::listop::ast(@_);
1991}
1992
1993package PLXML::op_uc;
1994
1995sub ast {
1996 my $self = shift;
1997 return $self->PLXML::listop::ast(@_);
1998}
1999
2000package PLXML::op_lc;
2001
2002sub ast {
2003 my $self = shift;
2004 return $self->PLXML::listop::ast(@_);
2005}
2006
2007package PLXML::op_quotemeta;
2008
2009sub ast {
2010 my $self = shift;
2011 return $self->PLXML::listop::ast(@_);
2012}
2013
2014package PLXML::op_rv2av;
2015
2016sub astnull {
2017 my $self = shift;
2018 return P5AST::op_rv2av->new(Kids => [$self->madness('$ @')]);
2019}
2020
2021sub ast {
2022 my $self = shift;
2023
2024 if (ref $$self{Kids}[0] eq 'PLXML::op_const' and $$self{mp}{'O'}) {
2025 return $self->madness('O');
2026 }
2027
2028 my @before;
2029 push @before, $self->madness('dx d (');
2030
2031 my @newkids;
2032 push @newkids, $self->madness('$ @ K');
2033 if (ref $$self{Kids}[0] ne "PLXML::op_gv") {
2034 push @newkids, $$self{Kids}[0]->ast();
2035 }
2036 my @after;
2037 push @after, $self->madness(') a');
2038 return $self->newtype->new(Kids => [@before, @newkids, @after]);
2039}
2040
2041package PLXML::op_aelemfast;
2042
2043sub ast {
2044 my $self = shift;
2045 return $self->madness('$');
2046}
2047
2048package PLXML::op_aelem;
2049
2050sub astnull {
2051 my $self = shift;
2052 my @newkids;
2053 push @newkids, $self->madness('dx d');
2054 for my $kid (@{$$self{Kids}}) {
2055 push @newkids, $kid->ast($self, @_);
2056 }
2057 splice @newkids, -1, 0, $self->madness('a [');
2058 push @newkids, $self->madness(']');
2059 return P5AST::op_aelem->new(Kids => [@newkids]);
2060}
2061
2062sub ast {
2063 my $self = shift;
2064
2065 my @before = $self->madness('dx d');
2066 my @newkids;
2067 for my $kid (@{$$self{Kids}}) {
2068 push @newkids, $kid->ast(@_);
2069 }
2070 splice @newkids, -1, 0, $self->madness('a [');
2071 push @newkids, $self->madness(']');
2072
2073 return $self->newtype->new(Kids => [@before, @newkids]);
2074}
2075
2076package PLXML::op_aslice;
2077
2078sub astnull {
2079 my $self = shift;
2080 my @newkids;
2081 push @newkids, $self->madness('[');
2082 for my $kid (@{$$self{Kids}}) {
2083 push @newkids, $kid->ast(@_);
2084 }
2085 unshift @newkids, pop @newkids;
2086 unshift @newkids, $self->madness('dx d');
2087 push @newkids, $self->madness(']');
2088 return P5AST::op_aslice->new(Kids => [@newkids]);
2089}
2090
2091sub ast {
2092 my $self = shift;
2093
2094 my @newkids;
2095 push @newkids, $self->madness('[');
2096 for my $kid (@{$$self{Kids}}) {
2097 push @newkids, $kid->ast(@_);
2098 }
2099 unshift @newkids, pop @newkids;
2100 unshift @newkids, $self->madness('dx d');
2101 push @newkids, $self->madness(']');
2102
2103 return $self->newtype->new(Kids => [@newkids]);
2104}
2105
2106package PLXML::op_each;
2107package PLXML::op_values;
2108package PLXML::op_keys;
2109package PLXML::op_delete;
2110package PLXML::op_exists;
2111package PLXML::op_rv2hv;
2112
2113sub astnull {
2114 my $self = shift;
2115 return P5AST::op_rv2hv->new(Kids => [$self->madness('$')]);
2116}
2117
2118sub ast {
2119 my $self = shift;
2120
2121 my @before;
2122 push @before, $self->madness('dx d (');
2123
2124 my @newkids;
2125 push @newkids, $self->madness('$ @ % K');
2126 if (ref $$self{Kids}[0] ne "PLXML::op_gv") {
2127 push @newkids, $$self{Kids}[0]->ast();
2128 }
2129 my @after;
2130 push @after, $self->madness(') a');
2131 return $self->newtype->new(Kids => [@before, @newkids, @after]);
2132}
2133
2134package PLXML::op_helem;
2135
2136sub astnull {
2137 my $self = shift;
2138 local $::curstate; # hash subscript potentially a lineseq
2139 local $::curenc = $::curenc;
2140
2141 my @newkids;
2142 push @newkids, $self->madness('dx d');
2143 for my $kid (@{$$self{Kids}}) {
2144 push @newkids, $kid->ast($self, @_);
2145 }
2146 splice @newkids, -1, 0, $self->madness('a {');
2147 push @newkids, $self->madness('}');
2148 return P5AST::op_helem->new(Kids => [@newkids]);
2149}
2150
2151sub ast {
2152 my $self = shift;
2153 local $::curstate; # hash subscript potentially a lineseq
2154 local $::curenc = $::curenc;
2155
2156 my @before = $self->madness('dx d');
2157 my @newkids;
2158 for my $kid (@{$$self{Kids}}) {
2159 push @newkids, $kid->ast($self, @_);
2160 }
2161 splice @newkids, -1, 0, $self->madness('a {');
2162 push @newkids, $self->madness('}');
2163
2164 return $self->newtype->new(Kids => [@before, @newkids]);
2165}
2166
2167
2168package PLXML::op_hslice;
2169
2170sub astnull {
2171 my $self = shift;
2172 my @newkids;
2173 push @newkids, $self->madness('{');
2174 for my $kid (@{$$self{Kids}}) {
2175 push @newkids, $kid->ast(@_);
2176 }
2177 unshift @newkids, pop @newkids;
2178 unshift @newkids, $self->madness('dx d');
2179 push @newkids, $self->madness('}');
2180 return P5AST::op_hslice->new(Kids => [@newkids]);
2181}
2182
2183sub ast {
2184 my $self = shift;
2185
2186 my @newkids;
2187 push @newkids, $self->madness('{');
2188 for my $kid (@{$$self{Kids}}) {
2189 push @newkids, $kid->ast(@_);
2190 }
2191 unshift @newkids, pop @newkids;
2192 unshift @newkids, $self->madness('dx d');
2193 push @newkids, $self->madness('}');
2194
2195 return $self->newtype->new(Kids => [@newkids]);
2196}
2197
2198package PLXML::op_unpack;
2199package PLXML::op_pack;
2200package PLXML::op_split;
6a28abbc
NC		 2201package PLXML::op_join;
2202package PLXML::op_list;
2203
2204sub astnull {
2205 my $self = shift;
2206 my @newkids;
2207 my @retval;
2208 my @before;
2209 if (@retval = $self->madness('X')) {
2210 push @before, $self->madness('x o');
2211 return @before,@retval;
2212 }
2213 my @kids = @{$$self{Kids}};
2214 for my $kid (@kids) {
2215 next if ref $kid eq 'PLXML::op_pushmark';
2216 next if ref $kid eq 'PLXML::op_null' and
2217 defined $$kid{was} and $$kid{was} eq 'pushmark';
2218 push @newkids, $kid->ast($self, @_);
2219 }
2220
2221 my $x = "";
2222 my @newnewkids = ();
2223 push @newnewkids, $self->madness('dx d (');
2224 push @newnewkids, @newkids;
2225 push @newnewkids, $self->madness(') :');
2226 return P5AST::op_list->new(Kids => [@newnewkids]);
2227}
2228
2229sub ast {
2230 my $self = shift;
2231
2232 my @retval;
2233 my @before;
2234 if (@retval = $self->madness('X')) {
2235 push @before, $self->madness('o');
2236 return $self->newtype->new(Kids => [@before,@retval]);
2237 }
2238 push @retval, $self->madness('dx d (');
2239
2240 my @newkids;
2241 for my $kid (@{$$self{Kids}}) {
2242 push @newkids, $kid->ast($self, @_);
2243 }
2244 my $x = "";
2245 my @newnewkids = ();
2246 push @newnewkids, @newkids;
2247 @newkids = @newnewkids;
2248 push @retval, @newkids;
2249 push @retval, $self->madness(') :');
2250 return $self->newtype->new(Kids => [@retval]);
2251}
2252
2253package PLXML::op_lslice;
2254
2255sub ast {
2256 my $self = shift;
2257 my @newkids;
2258
2259 if ($$self{mp}{q}) {
2260 push @newkids, $self->madness('q = Q');
2261 }
2262 elsif ($$self{mp}{x}) {
2263 push @newkids, $self->madness('x');
2264 }
2265 else {
2266 push @newkids, $self->madness('(');
2267 my $list = $$self{Kids}[1];
2268 push @newkids, $list->ast($self, @_);
2269 push @newkids, $self->madness(')');
2270 }
2271
2272 push @newkids, $self->madness('[');
2273
2274 my $slice = $$self{Kids}[0];
2275 push @newkids, $slice->ast($self, @_);
2276 push @newkids, $self->madness(']');
2277
2278 return $self->newtype->new(Kids => [@newkids]);
2279}
2280
2281package PLXML::op_anonlist;
2282package PLXML::op_anonhash;
2283package PLXML::op_splice;
2284package PLXML::op_push;
2285package PLXML::op_pop;
2286package PLXML::op_shift;
2287package PLXML::op_unshift;
2288package PLXML::op_sort;
2289package PLXML::op_reverse;
2290
2291sub astnull {
2292 my $self = shift;
2293 $self->PLXML::listop::ast(@_);
2294}
2295
2296package PLXML::op_grepstart;
2297package PLXML::op_grepwhile;
2298package PLXML::op_mapstart;
2299package PLXML::op_mapwhile;
2300package PLXML::op_range;
2301
2302sub ast {
2303 my $self = shift;
2304 return $self->PLXML::binop::ast(@_);
2305}
2306
2307package PLXML::op_flip;
2308package PLXML::op_flop;
2309package PLXML::op_and;
2310
2311sub astnull {
2312 my $self = shift;
2313 my @newkids;
2314 my @first = $self->madness('1');
2315 my @second = $self->madness('2');
2316 my @stuff = $$self{Kids}[0]->ast();
2317 if (my @I = $self->madness('I')) {
2318 if (@second) {
2319 push @newkids, @I;
2320 push @newkids, $self->madness('(');
2321 push @newkids, @stuff;
2322 push @newkids, $self->madness(')');
2323 push @newkids, @second;
2324 }
2325 else {
2326 push @newkids, @I;
2327 push @newkids, $self->madness('(');
2328 push @newkids, @first;
2329 push @newkids, $self->madness(')');
2330 push @newkids, @stuff;
2331 }
2332 }
2333 elsif (my @i = $self->madness('i')) {
2334 if (@second) {
2335 push @newkids, @second;
2336 push @newkids, @i;
2337 push @newkids, @stuff;
2338 }
2339 else {
2340 push @newkids, @stuff;
2341 push @newkids, @i;
2342 push @newkids, @first;
2343 }
2344 }
2345 elsif (my @o = $self->madness('o')) {
2346 if (@second) {
2347 push @newkids, @stuff;
2348 push @newkids, @o;
2349 push @newkids, @second;
2350 }
2351 else {
2352 push @newkids, @first;
2353 push @newkids, @o;
2354 push @newkids, @stuff;
2355 }
2356 }
2357 return P5AST::op_and->new(Kids => [@newkids]);
2358}
2359
2360package PLXML::op_or;
2361
2362sub astnull {
2363 my $self = shift;
2364 my @newkids;
2365 my @first = $self->madness('1');
2366 my @second = $self->madness('2');
2367 my @i = $self->madness('i');
2368 my @stuff = $$self{Kids}[0]->ast();
2369 if (@second) {
2370 if (@i) {
2371 push @newkids, @second;
2372 push @newkids, $self->madness('i');
2373 push @newkids, @stuff;
2374 }
2375 else {
2376 push @newkids, @stuff;
2377 push @newkids, $self->madness('o');
2378 push @newkids, @second;
2379 }
2380 }
2381 else {
2382 if (@i) {
2383 push @newkids, @stuff;
2384 push @newkids, $self->madness('i');
2385 push @newkids, @first;
2386 }
2387 else {
2388 push @newkids, @first;
2389 push @newkids, $self->madness('o');
2390 push @newkids, @stuff;
2391 }
2392 }
2393 return "P5AST::op_$$self{was}"->new(Kids => [@newkids]);
2394}
2395
2396
2397package PLXML::op_xor;
2398package PLXML::op_cond_expr;
2399package PLXML::op_andassign;
2400package PLXML::op_orassign;
2401package PLXML::op_method;
2402package PLXML::op_entersub;
2403
2404sub ast {
2405 my $self = shift;
2406
2407 if ($$self{mp}{q}) {
2408 return $self->madness('q = Q');
2409 }
2410 if ($$self{mp}{X}) { # <FH> override?
2411 return $self->madness('X');
2412 }
2413 if ($$self{mp}{A}) {
2414 return $self->astmethod(@_);
2415 }
2416 if ($$self{mp}{a}) {
2417 return $self->astarrow(@_);
2418 }
2419
2420 my @retval;
2421
2422 my @newkids;
2423 my @kids = @{$$self{Kids}};
2424 if (@kids == 1 and ref $kids[0] eq 'PLXML::op_null' and $kids[0]{was} =~ /list/) {
2425 @kids = @{$kids[0]{Kids}};
2426 }
2427 my $dest = pop @kids;
2428 my @dest = $dest->ast($self, @_);
2429
2430 if (ref($dest) =~ /method/) {
2431 my $invocant = shift @kids;
2432 $invocant = shift @kids if ref($invocant) eq 'PLXML::op_pushmark';
2433 my @invocant = $invocant->ast($self, @_);
2434 push @retval, @dest;
2435 push @retval, @invocant;
2436 }
2437 elsif (exists $$self{mp}{o} and $$self{mp}{o} eq 'do') {
2438 push @retval, $self->madness('o');
2439 push @retval, @dest;
2440 }
2441 else {
2442 push @retval, $self->madness('o');
2443 push @retval, @dest;
2444 }
2445 while (@kids) {
2446 my $kid = shift(@kids);
2447 push @newkids, $kid->ast($self, @_);
2448 }
2449
2450 push @retval, $self->madness('(');
2451 push @retval, @newkids;
2452 push @retval, $self->madness(')');
2453 return $self->newtype->new(Kids => [@retval]);
2454}
2455
2456sub astmethod {
2457 my $self = shift;
2458 my @newkids;
2459 my @kids;
2460 for my $kid (@{$$self{Kids}}) {
2461 next if ref $kid eq 'PLXML::op_pushmark';
2462 next if ref $kid eq 'PLXML::op_null' and
2463 defined $$kid{was} and $$kid{was} eq 'pushmark';
2464 push @kids, $kid;
2465 }
2466 my @invocant;
2467 if ($$self{flags} =~ /\bSTACKED\b/) {
2468 push @invocant, shift(@kids)->ast($self, @_);
2469 }
2470 for my $kid (@kids) {
2471 push @newkids, $kid->ast($self, @_);
2472 }
2473 my $dest = pop(@newkids);
2474 if (ref $dest eq 'PLXML::op_rv2cv' and $$self{flags} =~ /\bMOD\b/) {
2475 $dest = pop(@newkids);
2476 }
2477 my $x = "";
2478 my @retval;
2479 push @retval, @invocant;
2480 push @retval, $self->madness('A');
2481 push @retval, $dest;
2482 push @retval, $self->madness('(');
2483 push @retval, @newkids;
2484 push @retval, $self->madness(')');
2485 return $self->newtype->new(Kids => [@retval]);
2486}
2487
2488sub astarrow {
2489 my $self = shift;
2490 my @newkids;
2491 my @retval;
2492 my @kids = @{$$self{Kids}};
2493 if (@kids == 1 and ref $kids[0] eq 'PLXML::op_null' and $kids[0]{was} =~ /list/) {
2494 @kids = @{$kids[0]{Kids}};
2495 }
2496 while (@kids > 1) {
2497 my $kid = shift(@kids);
2498 push @newkids, $kid->ast($self, @_);
2499 }
2500 my @dest = $kids[0]->ast($self, @_);
2501 my $x = "";
2502 push @retval, @dest;
2503 push @retval, $self->madness('a');
2504 push @retval, $self->madness('(');
2505 push @retval, @newkids;
2506 push @retval, $self->madness(')');
2507 return $self->newtype->new(Kids => [@retval]);
2508}
2509
2510package PLXML::op_leavesub;
2511
2512sub ast {
2513 my $self = shift;
2514 if (ref $$self{Kids}[0] eq "PLXML::op_null") {
2515 return $$self{Kids}[0]->ast(@_);
2516 }
2517 return $$self{Kids}[0]->blockast($self, @_);
2518}
2519
2520package PLXML::op_leavesublv;
2521
2522sub ast {
2523 my $self = shift;
2524
2525 return $$self{Kids}[0]->blockast($self, @_);
2526}
2527
2528package PLXML::op_caller;
2529package PLXML::op_warn;
2530package PLXML::op_die;
2531package PLXML::op_reset;
2532package PLXML::op_lineseq;
2533
2534sub lineseq {
2535 my $self = shift;
2536 my @kids = @{$$self{Kids}};
2537 local $::curstate = 0; # (probably redundant, but that's okay)
2538 local $::prevstate = 0;
2539 local $::curenc = $::curenc;
2540 my @retval;
2541 my @newstuff;
2542 my $newprev;
2543 while (@kids) {
2544 my $kid = shift @kids;
2545 my $thing = $kid->ast($self, @_);
2546 next unless defined $thing;
2547 if ($::curstate ne $::prevstate) {
2548 if ($::prevstate) {
2549 push @newstuff, $::prevstate->madness(';');
2550 push @{$newprev->{Kids}}, @newstuff if $newprev;
2551 @newstuff = ();
2552 }
2553 $::prevstate = $::curstate;
2554 $newprev = $thing;
2555 push @retval, $thing;
2556 }
2557 elsif ($::prevstate) {
2558 push @newstuff, $thing;
2559 }
2560 else {
2561 push @retval, $thing;
2562 }
2563 }
2564 if ($::prevstate) {
2565 push @newstuff, $::prevstate->madness(';');
2566 push @{$newprev->{Kids}}, @newstuff if $newprev;
2567 @newstuff = ();
2568 $::prevstate = 0;
2569 }
2570 return @retval;
2571}
2572
2573sub blockast {
2574 my $self = shift;
2575 local $::curstate;
2576
2577 my @retval;
2578 push @retval, $self->madness('{');
2579
2580 my @newkids = $self->PLXML::op_lineseq::lineseq(@_);
2581 push @retval, @newkids;
2582
2583 push @retval, $self->madness('; }');
2584 return $self->newtype->new(Kids => [@retval]);
2585}
2586
2587package PLXML::op_nextstate;
2588
2589sub newtype { return "P5AST::statement" }
2590
2591sub astnull {
2592 my $self = shift;
2593 my @newkids;
2594 push @newkids, $self->madness('L');
2595 $::curstate = $self;
2596 return P5AST::statement->new(Kids => [@newkids]);
2597}
2598
2599sub ast {
2600 my $self = shift;
2601
2602 my @newkids;
2603 push @newkids, $self->madness('L');
2604 $::curstate = $self;
2605 return $self->newtype->new(Kids => [@newkids]);
2606}
2607
2608
2609package PLXML::op_dbstate;
2610package PLXML::op_unstack;
2611package PLXML::op_enter;
2612
2613sub ast { () }
2614
2615package PLXML::op_leave;
2616
2617sub astnull {
2618 ast(@_);
2619}
2620
2621sub ast {
2622 my $self = shift;
2623
2624 my $mad = $$self{mp}{FIRST} || "unknown";
2625
2626 my @retval;
2627 if ($mad eq 'w') {
2628 my @newkids;
2629 my @tmpkids;
2630 push @tmpkids, $self->{Kids};
2631 my $anddo = $$self{Kids}[-1]{Kids}[0]{Kids};
2632 eval { push @newkids, $anddo->[1]->ast($self,@_); };
2633 push @newkids, "[[[NOANDDO]]]" if $@;
2634 push @newkids, $self->madness('w');
2635 push @newkids, $anddo->[0]->ast($self,@_);
2636
2637 return $self->newtype->new(Kids => [@newkids]);
2638 }
2639
2640 local $::curstate;
2641 push @retval, $self->madness('o {');
2642
2643 my @newkids = $self->PLXML::op_lineseq::lineseq(@_);
2644 push @retval, @newkids;
2645 push @retval, $self->madness(q/; }/);
2646 my $retval = $self->newtype->new(Kids => [@retval]);
2647
2648 if ($$self{mp}{C}) {
2649 my @before;
2650 my @after;
2651 push @before, $self->madness('I ( C )');
2652 if ($$self{mp}{t}) {
2653 push @before, $self->madness('t');
2654 }
2655 elsif ($$self{mp}{e}) {
2656 push @after, $self->madness('e');
2657 }
2658 return P5AST::op_cond->new(Kids => [@before, $retval, @after]);
2659 }
2660 else {
2661 return $retval;
2662 }
2663}
2664
2665package PLXML::op_scope;
2666
2667sub ast {
2668 my $self = shift;
2669 local $::curstate;
2670
2671 my @newkids;
2672 push @newkids, $self->madness('o');
2673
2674 push @newkids, $self->madness('{');
2675 push @newkids, $self->PLXML::op_lineseq::lineseq(@_);
2676 push @newkids, $self->madness('; }');
2677
2678 my @folded = $self->madness('C');
2679 if (@folded) {
2680 my @t = $self->madness('t');
2681 my @e = $self->madness('e');
2682 if (@e) {
2683 return $self->newtype->new(
2684 Kids => [
2685 $self->madness('I ('),
2686 @folded,
2687 $self->madness(')'),
2688 $self->newtype->new(Kids => [@newkids]),
2689 @e
2690 ] );
2691 }
2692 else {
2693 return $self->newtype->new(
2694 Kids => [
2695 $self->madness('I ('),
2696 @folded,
2697 $self->madness(')'),
2698 @t,
2699 $self->newtype->new(Kids => [@newkids])
2700 ] );
2701 }
2702 }
2703 return $self->newtype->new(Kids => [@newkids]);
2704}
2705
2706package PLXML::op_enteriter;
2707
2708sub ast {
2709 my $self = shift;
2710 my (undef,$range,$var) = @{$self->{Kids}};
2711 my @retval;
2712 push @retval, $self->madness('v');
2713 if (!@retval and defined $var) {
2714 push @retval, $var->ast($self,@_);
2715 }
2716 else {
2717 push @retval, '';
2718 }
2719 if (ref $range eq 'PLXML::op_null' and $$self{flags} =~ /STACKED/) {
2720 my (undef,$min,$max) = @{$range->{Kids}};
2721 push @retval, $min->ast($self,@_);
2722 if (defined $max) {
2723 if (exists $$range{mp}{O}) { # deeply buried .. operator
2724 PLXML::prepreproc($$range{mp}{O});
2725 push @retval,
2726 $$range{mp}{'O'}{Kids}[0]{Kids}[0]{Kids}[0]{Kids}[0]->madness('o')
2727 }
2728 else {
2729 push @retval, '..'; # XXX missing whitespace
2730 }
2731 push @retval, $max->ast($self,@_);
2732 }
2733 }
2734 else {
2735 push @retval, $range->ast($self,@_);
2736 }
2737 return $self->newtype->new(Kids => [@retval]);
2738}
2739
2740package PLXML::op_iter;
2741package PLXML::op_enterloop;
2742
2743sub ast {
2744}
2745
2746package PLXML::op_leaveloop;
2747
2748sub ast {
2749 my $self = shift;
2750
2751 my @retval;
2752 my @newkids;
2753 my $enterloop = $$self{Kids}[0];
2754 my $nextthing = $$self{Kids}[1];
2755
2756 if ($$self{mp}{W}) {
2757 push @retval, $self->madness('L');
2758 push @newkids, $self->madness('W d');
2759
2760 if (ref $enterloop eq 'PLXML::op_enteriter') {
2761 my ($var,@rest) = @{$enterloop->ast($self,@_)->{Kids}};
2762 push @newkids, $var if $var;
2763 push @newkids, $self->madness('q ( x = Q');
2764 push @newkids, @rest;
2765 }
2766 else {
2767 push @newkids, $self->madness('(');
2768 push @newkids, $enterloop->ast($self,@_);
2769 }
2770 }
2771 my $andor;
2772
2773 if (ref $nextthing eq 'PLXML::op_null') {
2774 if ($$nextthing{mp}{'1'}) {
2775 push @newkids, $nextthing->madness('1');
2776 push @newkids, $self->madness(')');
2777 push @newkids, $$nextthing{Kids}[0]->blockast($self,@_);
2778 }
2779 elsif ($$nextthing{mp}{'2'}) {
2780 push @newkids, $$nextthing{Kids}[0]->ast($self,@_);
2781 push @newkids, $self->madness(')');
2782 push @newkids, $$nextthing{mp}{'2'}->blockast($self,@_);
2783 }
2784 elsif ($$nextthing{mp}{'U'}) {
2785 push @newkids, $nextthing->ast($self,@_);
2786 }
2787 else {
2788 # bypass the op_null
2789 $andor = $nextthing->{Kids}[0];
2790 eval {
2791 push @newkids, $$andor{Kids}[0]->ast($self, @_);
2792 };
2793 push @newkids, $self->madness(')');
2794 eval {
2795 push @newkids, $$andor{Kids}[1]->blockast($self, @_);
2796 };
2797 }
2798 }
2799 else {
2800 $andor = $nextthing;
2801 push @newkids, $nextthing->madness('O');
2802 push @newkids, $self->madness(')');
2803 push @newkids, $nextthing->blockast($self, @_);
2804 }
2805 if ($$self{mp}{w}) {
2806 push @newkids, $self->madness('w');
2807 push @newkids, $enterloop->ast($self,@_);
2808 }
2809
2810 push @retval, @newkids;
2811
2812 return $self->newtype->new(Kids => [@retval]);
2813}
2814
2815package PLXML::op_return;
2816package PLXML::op_last;
2817package PLXML::op_next;
2818package PLXML::op_redo;
2819package PLXML::op_dump;
2820package PLXML::op_goto;
2821package PLXML::op_exit;
2822package PLXML::op_open;
2823package PLXML::op_close;
2824package PLXML::op_pipe_op;
2825package PLXML::op_fileno;
2826package PLXML::op_umask;
2827package PLXML::op_binmode;
2828package PLXML::op_tie;
2829package PLXML::op_untie;
2830package PLXML::op_tied;
2831package PLXML::op_dbmopen;
2832package PLXML::op_dbmclose;
2833package PLXML::op_sselect;
2834package PLXML::op_select;
2835package PLXML::op_getc;
2836package PLXML::op_read;
2837package PLXML::op_enterwrite;
2838package PLXML::op_leavewrite;
2839package PLXML::op_prtf;
2840package PLXML::op_print;
793019c7 2841package PLXML::op_say;
6a28abbc
NC		 2842package PLXML::op_sysopen;
2843package PLXML::op_sysseek;
2844package PLXML::op_sysread;
2845package PLXML::op_syswrite;
2846package PLXML::op_send;
2847package PLXML::op_recv;
2848package PLXML::op_eof;
2849package PLXML::op_tell;
2850package PLXML::op_seek;
2851package PLXML::op_truncate;
2852package PLXML::op_fcntl;
2853package PLXML::op_ioctl;
2854package PLXML::op_flock;
2855package PLXML::op_socket;
2856package PLXML::op_sockpair;
2857package PLXML::op_bind;
2858package PLXML::op_connect;
2859package PLXML::op_listen;
2860package PLXML::op_accept;
2861package PLXML::op_shutdown;
2862package PLXML::op_gsockopt;
2863package PLXML::op_ssockopt;
2864package PLXML::op_getsockname;
2865package PLXML::op_getpeername;
2866package PLXML::op_lstat;
2867package PLXML::op_stat;
2868package PLXML::op_ftrread;
2869package PLXML::op_ftrwrite;
2870package PLXML::op_ftrexec;
2871package PLXML::op_fteread;
2872package PLXML::op_ftewrite;
2873package PLXML::op_fteexec;
2874package PLXML::op_ftis;
2875package PLXML::op_fteowned;
2876package PLXML::op_ftrowned;
2877package PLXML::op_ftzero;
2878package PLXML::op_ftsize;
2879package PLXML::op_ftmtime;
2880package PLXML::op_ftatime;
2881package PLXML::op_ftctime;
2882package PLXML::op_ftsock;
2883package PLXML::op_ftchr;
2884package PLXML::op_ftblk;
2885package PLXML::op_ftfile;
2886package PLXML::op_ftdir;
2887package PLXML::op_ftpipe;
2888package PLXML::op_ftlink;
2889package PLXML::op_ftsuid;
2890package PLXML::op_ftsgid;
2891package PLXML::op_ftsvtx;
2892package PLXML::op_fttty;
2893package PLXML::op_fttext;
2894package PLXML::op_ftbinary;
2895package PLXML::op_chdir;
2896package PLXML::op_chown;
2897package PLXML::op_chroot;
2898package PLXML::op_unlink;
2899package PLXML::op_chmod;
2900package PLXML::op_utime;
2901package PLXML::op_rename;
2902package PLXML::op_link;
2903package PLXML::op_symlink;
2904package PLXML::op_readlink;
2905package PLXML::op_mkdir;
2906package PLXML::op_rmdir;
2907package PLXML::op_open_dir;
2908package PLXML::op_readdir;
2909package PLXML::op_telldir;
2910package PLXML::op_seekdir;
2911package PLXML::op_rewinddir;
2912package PLXML::op_closedir;
2913package PLXML::op_fork;
2914package PLXML::op_wait;
2915package PLXML::op_waitpid;
2916package PLXML::op_system;
2917package PLXML::op_exec;
2918package PLXML::op_kill;
2919package PLXML::op_getppid;
2920package PLXML::op_getpgrp;
2921package PLXML::op_setpgrp;
2922package PLXML::op_getpriority;
2923package PLXML::op_setpriority;
2924package PLXML::op_time;
2925package PLXML::op_tms;
2926package PLXML::op_localtime;
2927package PLXML::op_gmtime;
2928package PLXML::op_alarm;
2929package PLXML::op_sleep;
2930package PLXML::op_shmget;
2931package PLXML::op_shmctl;
2932package PLXML::op_shmread;
2933package PLXML::op_shmwrite;
2934package PLXML::op_msgget;
2935package PLXML::op_msgctl;
2936package PLXML::op_msgsnd;
2937package PLXML::op_msgrcv;
2938package PLXML::op_semget;
2939package PLXML::op_semctl;
2940package PLXML::op_semop;
2941package PLXML::op_require;
2942package PLXML::op_dofile;
2943package PLXML::op_entereval;
2944
2945sub ast {
2946 my $self = shift;
2947 local $::curstate; # eval {} has own statement sequence
2948 return $self->SUPER::ast(@_);
2949}
2950
2951package PLXML::op_leaveeval;
2952package PLXML::op_entertry;
2953package PLXML::op_leavetry;
2954
2955sub ast {
2956 my $self = shift;
2957
2958 return $self->PLXML::op_leave::ast(@_);
2959}
2960
2961package PLXML::op_ghbyname;
2962package PLXML::op_ghbyaddr;
2963package PLXML::op_ghostent;
2964package PLXML::op_gnbyname;
2965package PLXML::op_gnbyaddr;
2966package PLXML::op_gnetent;
2967package PLXML::op_gpbyname;
2968package PLXML::op_gpbynumber;
2969package PLXML::op_gprotoent;
2970package PLXML::op_gsbyname;
2971package PLXML::op_gsbyport;
2972package PLXML::op_gservent;
2973package PLXML::op_shostent;
2974package PLXML::op_snetent;
2975package PLXML::op_sprotoent;
2976package PLXML::op_sservent;
2977package PLXML::op_ehostent;
2978package PLXML::op_enetent;
2979package PLXML::op_eprotoent;
2980package PLXML::op_eservent;
2981package PLXML::op_gpwnam;
2982package PLXML::op_gpwuid;
2983package PLXML::op_gpwent;
2984package PLXML::op_spwent;
2985package PLXML::op_epwent;
2986package PLXML::op_ggrnam;
2987package PLXML::op_ggrgid;
2988package PLXML::op_ggrent;
2989package PLXML::op_sgrent;
2990package PLXML::op_egrent;
2991package PLXML::op_getlogin;
2992package PLXML::op_syscall;
2993package PLXML::op_lock;
2994package PLXML::op_threadsv;
2995package PLXML::op_setstate;
2996package PLXML::op_method_named;
2997
2998sub ast {
2999 my $self = shift;
3000 return $self->madness('O');
3001}
3002
3003package PLXML::op_dor;
3004
3005sub astnull {
3006 my $self = shift;
3007 $self->PLXML::op_or::astnull(@_);
3008}
3009
3010package PLXML::op_dorassign;
3011package PLXML::op_custom;
3012
Unnamed repository; edit this file 'description' to name the repository.