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
21 while (@ARGV and $ARGV[0] =~ /^-./) {
23 if ($switch eq '-w') {
26 elsif ($switch eq '-Y') {
29 elsif ($switch eq '-d') {
33 die "Unrecognized switch: -$switch";
37 @ARGV = ('foo.xml') unless @ARGV;
42 $::curenc = 1; # start in iso-8859-1, sigh...
44 $::H = "HeredocHere000";
63 'o' => 'p5::operator',
64 '~' => 'p5::operator',
79 'a' => 'p5::operator',
80 'A' => 'p5::operator',
81 'd' => 'p5::declarator',
86 'q' => 'p5::openquote',
87 'Q' => 'p5::closequote',
91 's' => 'p5::declarator',
92 # 'V' => 'p5::version',
98 $e =~ s/\n$/\n [NODE $filename line $::prevstate->{line}]/ if $::prevstate;
103 $Data::Dumper::Indent = 1;
104 $Data::Dumper::Quotekeys = 0;
107 my $text = Dumper(@_);
108 # doesn't scale well, alas
109 1 while $text =~ s/(.*)^([^\n]*)bless\( \{\n(.*?)^(\s*\}), '([^']*)' \)([^\n]*)/$1$2$5 {\n$3$4$6 # $5/ms;
110 $text =~ s/PLXML:://g;
112 my ($package, $filename, $line) = caller;
113 my $subroutine = (caller(1))[3];
114 $text =~ s/\n?\z/, called from $subroutine, line $line\n/;
134 warn xdolist($indent,"LIST",@_);
137 my $type = ref $_[0];
139 warn xdoitem($indent,$type,@_);
142 warn xdoitem($indent,"ITEM",@_);
150 my $in = ' ' x ($indent * 2);
152 $result .= "$in<$tag>\n" if defined $tag;
154 my $itt = ref $it || "ITEM";
156 $result .= xdoitem($indent+1,$itt,$it);
158 $result .= "$in</$tag>\n" if defined $tag;
166 my $in = ' ' x ($indent * 2);
167 my $result = "$in<$tag>\n";
168 my @keys = sort keys %$hash;
171 $longest = length($k) if length($k) > $longest;
176 $K = $$hash{$k}, next if $k eq 'Kids';
177 my $sp = ' ' x ($longest - length($k));
178 if (ref $$hash{$k}) {
179 $tmp = xdoitem($indent+1,"kv",$$hash{$k});
180 $tmp =~ s!^ *<kv>\n *</kv>!$in <kv/>!;
183 $tmp = xdoitem($indent+1,"kv",$$hash{$k});
185 $k =~ s/([\t\n'"<>&])/$xmlrepl{$1}/g;
186 $tmp =~ s/<kv/<kv k='$k'$sp/ or
187 $tmp =~ s/^(.*)$/$in <kv k='$k'>\n$in $1$in <\/kv>\n/s;
191 $result .= xdolist($indent, undef, @$K);
193 $result .= "$in</$tag>\n";
200 my $in = ' ' x ($indent * 2);
203 $item =~ s/([\t\n'"<>&])/$xmlrepl{$1}/g;
204 return "$in<$tag>$item</$tag>\n";
206 (my $newtag = $r) =~ s/::/:/g;
208 if ($t =~ /\bARRAY\b/) {
210 return xdolist($indent,$tag,@{$item});
213 return "$in<$tag />\n";
216 if ($t =~ /\bHASH\b/) {
217 return xdohash($indent,$tag,$item);
220 return "$in<$newtag>$$item</$newtag>\n";
223 return "$in<$newtag type='$r'/>\n";
237 tdolist($indent,"LIST",@_);
240 my $type = ref $_[0];
242 tdoitem($indent,$type,@_);
245 tdoitem($indent,"ITEM",@_);
253 my $tag = shift || "ARRAY";
254 my $in = ' ' x ($indent * 2);
258 my $itt = ref $it || "ITEM";
259 print STDERR $in," ";
260 tdoitem($indent+1,$itt,$it);
274 my $in = ' ' x ($indent * 2);
276 print STDERR "$tag => {\n";
278 my @keys = sort keys %$hash;
281 $longest = length($k) if length($k) > $longest;
285 my $sp = ' ' x ($longest - length($k));
286 print STDERR "$in $k$sp => ";
287 tdoitem($indent+1,"",$$hash{$k});
289 print STDERR " # Kids";
293 print STDERR "$in} # $tag";
300 if (not defined $item) {
301 print STDERR "UNDEF";
304 # my $in = ' ' x ($indent * 2);
307 $item =~ s/([\t\n"])/$trepl{$1}/g;
308 print STDERR "\"$item\"";
313 my $str = $$item{uni};
314 my $enc = $enc[$$item{enc}] . ' ';
315 $enc =~ s/iso-8859-1 //;
316 $str =~ s/([\t\n"])/$trepl{$1}/g;
317 print STDERR "$r $enc\"$str\"";
319 elsif ($t =~ /\bARRAY\b/) {
320 tdolist($indent,$tag,@{$item});
322 elsif ($t =~ /\bHASH\b/) {
323 tdohash($indent,$tag,$item);
326 print STDERR "$r type='$r'";
333 if (not exists $enc{$encname}) {
335 return $enc{$encname} = $#enc;
337 return $enc{$encname};
343 my $p1 = new XML::Parser(Style => 'Objects', Pkg => 'PLXML');
344 $p1->setHandlers('Char' => sub { warn "Chars $_[1]" if $_[1] =~ /\S/; });
346 # First slurp XML into tree of objects.
348 my $root = $p1->parsefile($filename);
350 # Now turn XML tree into something more like an AST.
352 PLXML::prepreproc($root->[0]);
353 my $ast = P5AST->new('Kids' => [$root->[0]->ast()]);
358 print YAML::Syck::Dump($ast);
362 # Finally, walk AST to produce new program.
364 my $text = $ast->p5text(); # returns encoded, must output raw
374 die "Too many args to new" if @_;
375 die "Attempt to bless non-text $text" if ref $text;
376 return bless( { uni => $text,
381 sub uni { my $self = shift; $$self{uni}; } # internal stuff all in utf8
385 my $enc = $enc[$$self{enc} || 0];
386 return encode($enc, $$self{uni});
389 package p5::closequote; BEGIN { @p5::closequote::ISA = 'p5::punct'; }
390 package p5::closer; BEGIN { @p5::closer::ISA = 'p5::punct'; }
391 package p5::declarator; BEGIN { @p5::declarator::ISA = 'p5::token'; }
392 package p5::junk; BEGIN { @p5::junk::ISA = 'p5::text'; }
393 package p5::label; BEGIN { @p5::label::ISA = 'p5::token'; }
394 #package p5::name; BEGIN { @p5::name::ISA = 'p5::token'; }
395 package p5::opener; BEGIN { @p5::opener::ISA = 'p5::punct'; }
396 package p5::openquote; BEGIN { @p5::openquote::ISA = 'p5::punct'; }
397 package p5::operator; BEGIN { @p5::operator::ISA = 'p5::token'; }
398 package p5::punct; BEGIN { @p5::punct::ISA = 'p5::token'; }
399 package p5::remod; BEGIN { @p5::remod::ISA = 'p5::token'; }
400 package p5::sigil; BEGIN { @p5::sigil::ISA = 'p5::punct'; }
401 package p5::token; BEGIN { @p5::token::ISA = 'p5::text'; }
402 #package p5::version; BEGIN { @p5::version::ISA = 'p5::token'; }
404 ################################################################
405 # Routines to turn XML tree into an AST. Mostly this amounts to hoisting
406 # misplaced nodes and flattening various things into lists.
411 ::x("AUTOLOAD $PLXML::AUTOLOAD", @_);
412 return "[[[ $PLXML::AUTOLOAD ]]]";
417 my $kids = $$self{Kids};
421 for ($i = 0; $i < @$kids; $i++) {
422 if (ref $kids->[$i] eq "PLXML::madprops") {
423 $self->{mp} = splice(@$kids, $i, 1)->hash($self,@_);
428 prepreproc($kids->[$i], $self, @_);
436 if (ref $self eq 'PLXML::op_null' and $$self{was}) {
437 return "PLXML::op_$$self{was}"->key();
446 my $t = ref $self || $self;
447 $t = "PLXML::op_$$self{was}" if $t eq 'PLXML::op_null' and $$self{was};
448 $t =~ s/PLXML/P5AST/ or die "Bad type: $t";
454 my @keys = split(' ', shift);
456 for my $key (@keys) {
457 my $madprop = $self->{mp}{$key};
458 next unless defined $madprop;
459 if (ref $madprop eq 'PLXML::mad_op') {
461 push @vals, $madprop->blockast($self, @_);
464 push @vals, $madprop->ast($self, @_);
469 if ($white = $self->{mp}{"_$key"}) {
470 push @vals, p5::junk->new($white);
472 my $type = $madtype{$key} || "p5::token";
473 push @vals, $type->new($madprop);
474 if ($white = $self->{mp}{"#$key"}) {
475 push @vals, p5::junk->new($white);
490 for my $kid (@{$$self{Kids}}) {
491 push @newkids, $kid->ast($self, @_);
493 return $self->newtype->new(Kids => [uc $self->key(), "(", @newkids, ")"]);
498 my $desc = $self->desc();
499 if ($desc =~ /\((.*?)\)/) {
503 return " <<" . $self->key() . ">> ";
512 package PLXML::Characters;
514 sub ast { die "oops" }
515 sub pair { die "oops" }
517 package PLXML::madprops;
530 # We need to guarantee key uniqueness at this point.
531 for my $kid (@{$$self{Kids}}) {
532 my ($k,$v) = $kid->pair($self, @_);
534 if ($k =~ /^[_#]$/) { # rekey whitespace according to preceding entry
535 $k .= $lastthing; # (which is actually the token the whitespace is before)
538 $k .= 'x' while exists $hash{$k};
543 $hash{FIRST} = $firstthing;
544 $hash{LAST} = $lastthing;
548 package PLXML::mad_op;
552 my $key = $$self{key};
558 $self->prepreproc(@_);
560 for my $kid (@{$$self{Kids}}) {
561 push @vals, $kid->ast($self, @_);
567 return P5AST::op_list->new(Kids => [@vals]);
573 $self->prepreproc(@_);
575 for my $kid (@{$$self{Kids}}) {
576 push @vals, $kid->blockast($self, @_);
582 return P5AST::op_lineseq->new(Kids => [@vals]);
586 package PLXML::mad_pv;
590 my $key = $$self{key};
591 my $val = $$self{val};
592 $val =~ s/STUPIDXML\(#x(\w+)\)/chr(hex $1)/eg;
596 package PLXML::mad_sv;
600 my $key = $$self{key};
601 my $val = $$self{val};
602 $val =~ s/STUPIDXML\(#x(\w+)\)/chr(hex $1)/eg;
606 package PLXML::baseop;
613 push @retval, $self->madness('M ox');
614 for my $kid (@{$$self{Kids}}) {
615 push @newkids, $kid->ast($self, @_);
618 push @retval, uc $self->key(), "(", @newkids , ")";
621 push @retval, $self->madness('o ( )');
623 return $self->newtype->new(Kids => [@retval]);
626 package PLXML::baseop_unop;
630 my @newkids = $self->madness('d M ox o (');
632 if (exists $$self{Kids}) {
633 my $arg = $$self{Kids}[0];
634 push @newkids, $arg->ast($self, @_) if defined $arg;
636 push @newkids, $self->madness(')');
638 return $self->newtype()->new(Kids => [@newkids]);
641 package PLXML::binop;
647 push @newkids, $self->madness('M ox');
649 my $left = $$self{Kids}[0];
650 push @newkids, $left->ast($self, @_);
652 push @newkids, $self->madness('o');
654 my $right = $$self{Kids}[1];
655 if (defined $right) {
656 push @newkids, $right->ast($self, @_);
659 return $self->newtype->new(Kids => [@newkids]);
664 package PLXML::filestatop;
669 my @newkids = $self->madness('o (');
671 if (@{$$self{Kids}}) {
672 for my $kid (@{$$self{Kids}}) {
673 push @newkids, $kid->ast($self, @_);
677 push @newkids, $self->madness('O');
679 push @newkids, $self->madness(')');
681 return $self->newtype->new(Kids => [@newkids]);
684 package PLXML::listop;
692 if (@before = $self->madness('M')) {
693 push @before, $self->madness('ox'); # o is the function name
695 if (@retval = $self->madness('X')) {
696 push @before, $self->madness('o x');
697 return P5AST::listop->new(Kids => [@before,@retval]);
700 push @retval, $self->madness('o ( [ {');
703 for my $kid (@{$$self{Kids}}) {
704 next if ref $kid eq 'PLXML::op_pushmark';
705 next if ref $kid eq 'PLXML::op_null' and
706 defined $$kid{was} and $$kid{was} eq 'pushmark';
707 push @newkids, $kid->ast($self, @_);
713 push @retval, $self->madness('S');
715 push @retval, @newkids;
717 push @retval, $self->madness('} ] )');
718 return $self->newtype->new(Kids => [@before,@retval,@after]);
721 package PLXML::logop;
727 push @newkids, $self->madness('o (');
728 for my $kid (@{$$self{Kids}}) {
729 push @newkids, $kid->ast($self, @_);
731 push @newkids, $self->madness(')');
732 return $self->newtype->new(Kids => [@newkids]);
737 package PLXML::loopexop;
741 my @newkids = $self->madness('o (');
743 if ($$self{mp}{L} or not $$self{flags} =~ /\bSPECIAL\b/) {
744 my @label = $self->madness('L');
746 push @newkids, @label;
749 my $arg = $$self{Kids}[0];
750 push @newkids, $arg->ast($self, @_) if defined $arg;
753 push @newkids, $self->madness(')');
755 return $self->newtype->new(Kids => [@newkids]);
759 package PLXML::padop;
761 package PLXML::padop_svop;
768 return P5AST::pmop->new(Kids => []) unless exists $$self{flags};
770 my $bits = $self->fetchbits($$self{flags},@_);
773 if ($bits->{binding}) {
774 push @newkids, $bits->{binding};
775 push @newkids, $self->madness('~');
777 if (exists $bits->{regcomp} and $bits->{regcomp}) {
778 my @front = $self->madness('q');
779 my @back = $self->madness('Q');
780 push @newkids, @front, $bits->{regcomp}, @back,
783 elsif ($$self{mp}{q}) {
784 push @newkids, $self->madness('q = Q m');
786 elsif ($$self{mp}{X}) {
787 push @newkids, $self->madness('X m');
790 push @newkids, $self->madness('e m');
793 return $self->newtype->new(Kids => [@newkids]);
799 for my $key (grep {!/^Kids/} keys %$pmop) {
800 $bits->{$key} = $pmop->{$key};
803 # Have to delete all the fake evals of the repl. This is a pain...
804 if (@{$$pmop{Kids}}) {
805 my $really = $$pmop{Kids}[0]{Kids}[0];
806 if (ref $really eq 'PLXML::op_substcont') {
807 $really = $$really{Kids}[0];
809 while ((ref $really) =~ /^PLXML::op_.*(null|entereval)/) {
810 if (exists $$really{was}) {
811 $bits->{repl} = $really->ast(@_);
814 $really = $$really{Kids}[0];
816 if (ref $really eq 'PLXML::op_scope' and
817 @{$$really{Kids}} == 1 and
818 ref $$really{Kids}[0] eq 'PLXML::op_null' and
819 not @{$$really{Kids}[0]{Kids}})
824 if (ref $really eq 'PLXML::op_leave' and
825 @{$$really{Kids}} == 2 and
826 ref $$really{Kids}[1] eq 'PLXML::op_null' and
827 not @{$$really{Kids}[1]{Kids}})
832 if ((ref $really) =~ /^PLXML::op_(scope|leave)/) {
833 # should be at inner do {...} here, so skip that fakery too
834 $bits->{repl} = $really->newtype->new(Kids => [$really->PLXML::op_lineseq::lineseq(@_)]);
835 # but retrieve the whitespace before fake '}'
836 if ($$really{mp}{'_}'}) {
837 push(@{$bits->{repl}->{Kids}}, p5::junk->new($$really{mp}{'_}'}));
840 else { # something else, padsv probably
841 $bits->{repl} = $really->ast(@_);
848 my $flags = shift || '';
850 my @kids = @{$$self{Kids}};
853 my $arg = shift @kids;
854 innerpmop($arg,\%bits, $self, @_);
855 if ($flags =~ /STACKED/) {
857 $bits{binding} = $arg->ast($self, @_);
859 if ($bits{when} ne "COMP" and @kids) {
861 $bits{regcomp} = $arg->ast($self, @_);
863 if (not exists $bits{repl} and @kids) {
865 $bits{repl} = $arg->ast($self, @_);
871 package PLXML::pvop_svop;
877 my @newkids = $self->madness('o (');
879 if (exists $$self{Kids}) {
880 my $arg = $$self{Kids}[0];
881 push @newkids, $arg->ast($self, @_) if defined $arg;
883 push @newkids, $self->madness(')');
885 return $self->newtype->new(Kids => [@newkids]);
889 package PLXML::Characters;
890 package PLXML::madprops;
891 package PLXML::mad_op;
892 package PLXML::mad_pv;
893 package PLXML::baseop;
894 package PLXML::baseop_unop;
895 package PLXML::binop;
897 package PLXML::filestatop;
898 package PLXML::listop;
899 package PLXML::logop;
901 package PLXML::loopexop;
902 package PLXML::padop;
903 package PLXML::padop_svop;
905 package PLXML::pvop_svop;
907 package PLXML::op_null;
909 # Null nodes typed by first madprop.
915 'p' => sub { # peg for #! line, etc.
918 push @newkids, $self->madness('p px');
920 return P5AST::peg->new(Kids => [@newkids])
922 '(' => sub { # extra parens around the whole thing
925 push @newkids, $self->madness('dx d o (');
926 for my $kid (@{$$self{Kids}}) {
927 push @newkids, $kid->ast($self, @_);
929 push @newkids, $self->madness(')');
930 return P5AST::parens->new(Kids => [@newkids])
932 '~' => sub { # binding operator
935 push @newkids, $$self{Kids}[0]->ast($self,@_);
936 push @newkids, $self->madness('~');
937 push @newkids, $$self{Kids}[1]->ast($self,@_);
938 return P5AST::bindop->new(Kids => [@newkids])
940 ';' => sub { # null statements/blocks
943 push @newkids, $self->madness('{ ; }');
945 return P5AST::nothing->new(Kids => [@newkids])
947 'I' => sub { # if or unless statement keyword
950 push @newkids, $self->madness('L I (');
952 for my $kid (@{$$self{Kids}}) {
953 push @subkids, $kid->ast($self, @_);
955 die "oops in op_null->new" unless @subkids == 1;
956 my $newself = $subkids[0];
957 @subkids = @{$$newself{Kids}};
959 unshift @{$subkids[0]{Kids}}, @newkids;
960 push @{$subkids[0]{Kids}}, $self->madness(')');
961 return bless($newself, 'P5AST::condstate');
966 my @module = $self->madness('U');
967 my @args = $self->madness('A');
968 my $module = $module[-1]{Kids}[-1];
969 if ($module->uni eq 'bytes') {
970 $::curenc = ::encnum('iso-8859-1');
972 elsif ($module->uni eq 'utf8') {
973 if ($$self{mp}{o} eq 'no') {
974 $::curenc = ::encnum('iso-8859-1');
977 $::curenc = ::encnum('utf-8');
980 elsif ($module->uni eq 'encoding') {
981 if ($$self{mp}{o} eq 'no') {
982 $::curenc = ::encnum('iso-8859-1');
985 $::curenc = ::encnum(eval $args[0]->p5text); # XXX bletch
988 # (Surrounding {} ends up here if use is only thing in block.)
989 push @newkids, $self->madness('{ o');
990 push @newkids, @module;
991 push @newkids, $self->madness('V');
992 push @newkids, @args;
993 push @newkids, $self->madness('S ; }');
995 return P5AST::use->new(Kids => [@newkids])
997 '?' => sub { # ternary
1001 my @condkids = @{$$self{Kids}[0]{Kids}};
1003 push @newkids, $condkids[0]->ast($self,@_), $self->madness('?');
1004 push @newkids, $condkids[1]->ast($self,@_), $self->madness(':');
1005 push @newkids, $condkids[2]->ast($self,@_);
1006 return P5AST::ternary->new(Kids => [@newkids])
1008 '&' => sub { # subroutine
1011 push @newkids, $self->madness('d n s a : { & } ;');
1013 return P5AST::sub->new(Kids => [@newkids])
1015 'i' => sub { # modifier if
1018 push @newkids, $self->madness('i');
1019 my $cond = $$self{Kids}[0];
1021 for my $kid (@{$$cond{Kids}}) {
1022 push @subkids, $kid->ast($self, @_);
1024 push @newkids, shift @subkids;
1025 unshift @newkids, @subkids;
1026 return P5AST::condmod->new(Kids => [@newkids])
1028 'P' => sub { # package declaration
1031 push @newkids, $self->madness('o');
1032 push @newkids, $self->madness('P');
1033 push @newkids, $self->madness(';');
1035 return P5AST::package->new(Kids => [@newkids])
1037 'F' => sub { # format
1039 my @newkids = $self->madness('F n b');
1041 return P5AST::format->new(Kids => [@newkids])
1043 'x' => sub { # qw literal
1045 return P5AST::qwliteral->new(Kids => [$self->madness('x')])
1047 'q' => sub { # random quote
1049 return P5AST::quote->new(Kids => [$self->madness('q = Q')])
1051 'X' => sub { # random literal
1053 return P5AST::token->new(Kids => [$self->madness('X')])
1055 ':' => sub { # attr list
1057 return P5AST::attrlist->new(Kids => [$self->madness(':')])
1059 ',' => sub { # "unary ," so to speak
1062 push @newkids, $self->madness(',');
1063 push @newkids, $$self{Kids}[0]->ast($self,@_);
1064 return P5AST::listelem->new(Kids => [@newkids])
1066 'C' => sub { # constant conditional
1069 push @newkids, $$self{Kids}[0]->ast($self,@_);
1070 my @folded = $self->madness('C');
1072 my @t = $self->madness('t');
1073 my @e = $self->madness('e');
1075 return P5AST::op_cond_expr->new(
1077 $self->madness('I ('),
1079 $self->madness(') ?'),
1080 P5AST::op_cond_expr->new(Kids => [@newkids]),
1081 $self->madness(':'),
1086 return P5AST::op_cond_expr->new(
1088 $self->madness('I ('),
1090 $self->madness(') ?'),
1092 $self->madness(':'),
1097 return P5AST::op_null->new(Kids => [@newkids])
1099 '+' => sub { # unary +
1102 push @newkids, $self->madness('+');
1103 push @newkids, $$self{Kids}[0]->ast($self,@_);
1104 return P5AST::preplus->new(Kids => [@newkids])
1106 'D' => sub { # do block
1109 push @newkids, $self->madness('D');
1110 push @newkids, $$self{Kids}[0]->ast($self,@_);
1111 return P5AST::doblock->new(Kids => [@newkids])
1113 '3' => sub { # C-style for loop
1118 my (undef, $init, $lineseq) = @{$$self{Kids}[0]{Kids}};
1119 my (undef, $leaveloop) = @{$$lineseq{Kids}};
1120 my (undef, $null) = @{$$leaveloop{Kids}};
1126 if (exists $$null{was} and $$null{was} eq 'and') {
1127 ($lineseq2) = @{$$null{Kids}};
1130 ($and) = @{$$null{Kids}};
1131 ($cond, $lineseq2) = @{$$and{Kids}};
1133 if ($$lineseq2{mp}{'{'}) {
1137 ($block, $cont) = @{$$lineseq2{Kids}};
1140 push @newkids, $self->madness('L 3 (');
1141 push @newkids, $init->ast($self,@_);
1142 push @newkids, $self->madness('1');
1143 if (defined $cond) {
1144 push @newkids, $cond->ast($self,@_);
1146 elsif (defined $null) {
1147 push @newkids, $null->madness('1');
1149 push @newkids, $self->madness('2');
1150 if (defined $cont) {
1151 push @newkids, $cont->ast($self,@_);
1153 push @newkids, $self->madness(')');
1154 push @newkids, $block->blockast($self,@_);
1156 return P5AST::cfor->new(Kids => [@newkids])
1158 'o' => sub { # random useless operator
1161 push @newkids, $self->madness('o');
1162 my $kind = $newkids[-1] || '';
1163 $kind = $kind->uni if ref $kind;
1165 for my $kid (@{$$self{Kids}}) {
1166 push @subkids, $kid->ast($self, @_);
1168 if ($kind eq '=') { # stealth readline
1169 unshift(@newkids, shift(@subkids));
1170 push(@newkids, @subkids);
1171 return P5AST::op_aassign->new(Kids => [@newkids])
1174 my $newself = $subkids[0];
1175 splice(@{$newself->{Kids}}, 1, 0,
1176 $self->madness('ox ('),
1186 # Null nodes are an untyped mess inside Perl. Instead of fixing it there,
1187 # we derive an effective type either from the "was" field or the first madprop.
1188 # (The individual routines select the actual new type.)
1192 my $was = $$self{was} || 'peg';
1193 my $mad = $$self{mp}{FIRST} || "unknown";
1195 # First try for a "was".
1196 my $meth = "PLXML::op_${was}::astnull";
1197 if (exists &{$meth}) {
1198 return $self->$meth(@_);
1201 # Look at first madprop.
1202 if (exists $astmad{$mad}) {
1203 return $astmad{$mad}->($self);
1205 warn "No mad $mad" unless $mad eq 'unknown';
1207 # Do something generic.
1209 for my $kid (@{$$self{Kids}}) {
1210 push @newkids, $kid->ast($self, @_);
1212 return $self->newtype->new(Kids => [@newkids]);
1218 local $::curenc = $::curenc;
1219 return $self->madness('{ ; }');
1222 package PLXML::op_stub;
1226 return $self->newtype->new(Kids => [$self->madness(', x ( ) q = Q')]);
1229 package PLXML::op_scalar;
1234 my @pre = $self->madness('o q');
1236 if ($op->uni =~ /^<</) {
1238 my $opstub = bless { start => $op }, 'P5AST::heredoc';
1239 push @newkids, $opstub;
1240 push @newkids, $self->madness('(');
1242 my @kids = @{$$self{Kids}};
1245 for my $kid (@kids) {
1246 next if ref $kid eq 'PLXML::op_pushmark';
1247 next if ref $kid eq 'PLXML::op_null' and
1248 defined $$kid{was} and $$kid{was} eq 'pushmark';
1249 push @divert, $kid->ast($self, @_);
1251 $opstub->{doc} = P5AST::op_list->new(Kids => [@divert]);
1252 $opstub->{end} = ($self->madness('Q'))[-1];
1254 push @newkids, $self->madness(')');
1256 return $self->newtype->new(Kids => [@pre,@newkids]);
1258 return $self->PLXML::baseop_unop::ast();
1261 package PLXML::op_pushmark;
1265 package PLXML::op_wantarray;
1266 package PLXML::op_const;
1271 return unless $$self{mp};
1272 push @newkids, $self->madness('q = Q X : f O ( )');
1273 return P5AST::op_const->new(Kids => [@newkids]);
1278 return unless %{$$self{mp}};
1283 my @args = $self->madness('f');
1286 elsif (exists $self->{mp}{q}) {
1287 push @args, $self->madness('d q');
1288 if ($args[-1]->uni =~ /^<</) {
1289 my $opstub = bless { start => pop(@args) }, 'P5AST::heredoc';
1290 $opstub->{doc} = P5AST::op_const->new(Kids => [$self->madness('=')]);
1291 $opstub->{end} = ($self->madness('Q'))[-1];
1292 push @args, $opstub;
1295 push @args, $self->madness('= Q');
1298 elsif (exists $self->{mp}{X}) {
1299 push @before, $self->madness('d'); # was local $[ probably
1300 if (not $$self{mp}{O}) {
1301 push @before, $self->madness('o'); # was unary
1303 my @X = $self->madness(': X');
1304 if (exists $$self{private} and $$self{private} =~ /BARE/) {
1305 return $self->newtype->new(Kids => [@X]);
1310 $self->madness('x'),
1312 if ($$self{mp}{O}) {
1313 push @args, $self->madness('o O');
1316 elsif (exists $self->{mp}{O}) {
1317 push @args, $self->madness('O');
1319 elsif ($$self{private} =~ /\bBARE\b/) {
1320 @args = ($$self{PV});
1322 elsif (exists $$self{mp}{o}) {
1323 @args = $self->madness('o');
1325 elsif (exists $$self{PV}) {
1326 @args = ('"', $$self{PV}, '"');
1328 elsif (exists $$self{NV}) {
1331 elsif (exists $$self{IV}) {
1335 @args = $self->SUPER::text(@_);
1337 return $self->newtype->new(Kids => [@before, @args]);
1341 package PLXML::op_gvsv;
1347 for my $attr (qw/gv GV flags/) {
1348 if (exists $$self{$attr}) {
1349 push @args, $attr, $$self{$attr};
1352 push @retval, @args;
1353 push @retval, $self->madness('X');
1354 return $self->newtype->new(Kids => [@retval]);
1357 package PLXML::op_gv;
1362 push @newkids, $self->madness('X K');
1364 return $self->newtype->new(Kids => [@newkids]);
1367 package PLXML::op_gelem;
1372 local $::curstate; # in case there are statements in subscript
1373 local $::curenc = $::curenc;
1375 push @newkids, $self->madness('dx d');
1376 for my $kid (@{$$self{Kids}}) {
1377 push @newkids, $kid->ast($self, @_);
1379 splice @newkids, -1, 0, $self->madness('o {');
1380 push @newkids, $self->madness('}');
1382 return $self->newtype->new(Kids => [@newkids]);
1385 package PLXML::op_padsv;
1390 push @args, $self->madness('dx d ( $ )');
1392 return $self->newtype->new(Kids => [@args]);
1395 package PLXML::op_padav;
1397 sub astnull { ast(@_) }
1402 push @retval, $self->madness('dx d (');
1403 push @retval, $self->madness('$ @');
1404 push @retval, $self->madness(') o O');
1405 return $self->newtype->new(Kids => [@retval]);
1408 package PLXML::op_padhv;
1410 sub astnull { ast(@_) }
1415 push @retval, $self->madness('dx d (');
1416 push @retval, $self->madness('$ @ %');
1417 push @retval, $self->madness(') o O');
1418 return $self->newtype->new(Kids => [@retval]);
1421 package PLXML::op_padany;
1423 package PLXML::op_pushre;
1427 if ($$self{mp}{q}) {
1428 return $self->madness('q = Q m');
1430 if ($$self{mp}{X}) {
1431 return $self->madness('X m');
1433 if ($$self{mp}{e}) {
1434 return $self->madness('e m');
1436 return $$self{Kids}[1]->ast($self,@_), $self->madness('m');
1439 package PLXML::op_rv2gv;
1445 push @newkids, $self->madness('dx d ( * $');
1446 push @newkids, $$self{Kids}[0]->ast();
1447 push @newkids, $self->madness(')');
1448 return $self->newtype->new(Kids => [@newkids]);
1451 package PLXML::op_rv2sv;
1455 return P5AST::op_rv2sv->new(Kids => [$self->madness('O o dx d ( $ ) : a')]);
1462 push @newkids, $self->madness('dx d ( $');
1463 if (ref $$self{Kids}[0] ne "PLXML::op_gv") {
1464 push @newkids, $$self{Kids}[0]->ast();
1466 push @newkids, $self->madness(') : a');
1467 return $self->newtype->new(Kids => [@newkids]);
1470 package PLXML::op_av2arylen;
1476 push @newkids, $$self{Kids}[0]->madness('l');
1477 push @newkids, $$self{Kids}[0]->ast();
1478 return $self->newtype->new(Kids => [@newkids]);
1481 package PLXML::op_rv2cv;
1486 push @newkids, $self->madness('X');
1487 return @newkids if @newkids;
1488 if (exists $$self{mp}{'&'}) {
1489 push @newkids, $self->madness('&');
1490 if (@{$$self{Kids}}) {
1491 push @newkids, $$self{Kids}[0]->ast(@_);
1495 push @newkids, $$self{Kids}[0]->ast(@_);
1497 return P5AST::op_rv2cv->new(Kids => [@newkids]);
1504 push @newkids, $self->madness('&');
1505 if (@{$$self{Kids}}) {
1506 push @newkids, $$self{Kids}[0]->ast();
1508 return $self->newtype->new(Kids => [@newkids]);
1511 package PLXML::op_anoncode;
1515 my $arg = $$self{Kids}[0];
1516 local $::curstate; # hide nested statements in sub
1517 local $::curenc = $::curenc;
1519 return $arg->ast(@_);
1521 return ';'; # XXX literal ; should come through somewhere
1524 package PLXML::op_prototype;
1525 package PLXML::op_refgen;
1529 my @newkids = $self->madness('o s a');
1531 if (exists $$self{Kids}) {
1532 my $arg = $$self{Kids}[0];
1533 push @newkids, $arg->ast($self, @_) if defined $arg;
1536 my $res = $self->newtype->new(Kids => [@newkids]);
1540 package PLXML::op_srefgen;
1545 if ($$self{mp}{FIRST} eq '{') {
1546 local $::curstate; # this is officially a block, so hide it
1547 local $::curenc = $::curenc;
1548 push @newkids, $self->madness('{');
1549 for my $kid (@{$$self{Kids}}) {
1550 push @newkids, $kid->ast($self, @_);
1552 push @newkids, $self->madness('; }');
1553 return P5AST::op_stringify->new(Kids => [@newkids]);
1556 push @newkids, $self->madness('o [');
1557 for my $kid (@{$$self{Kids}}) {
1558 push @newkids, $kid->ast($self, @_);
1560 push @newkids, $self->madness(']');
1561 return P5AST::op_stringify->new(Kids => [@newkids]);
1565 package PLXML::op_ref;
1566 package PLXML::op_bless;
1567 package PLXML::op_backtick;
1572 if (exists $self->{mp}{q}) {
1573 push @args, $self->madness('q');
1574 if ($args[-1]->uni =~ /^<</) {
1575 my $opstub = bless { start => $args[-1] }, 'P5AST::heredoc';
1576 $args[-1] = $opstub;
1577 $opstub->{doc} = P5AST::op_const->new(Kids => [$self->madness('=')]);
1578 $opstub->{end} = ($self->madness('Q'))[-1];
1581 push @args, $self->madness('= Q');
1584 return $self->newtype->new(Kids => [@args]);
1587 package PLXML::op_glob;
1591 my @retval = $self->madness('o q = Q');
1592 if (not @retval or $retval[-1]->uni eq 'glob') {
1593 push @retval, $self->madness('(');
1594 push @retval, $$self{Kids}[0]->ast($self,@_);
1595 push @retval, $self->madness(')');
1597 return P5AST::op_glob->new(Kids => [@retval]);
1600 package PLXML::op_readline;
1605 if (exists $$self{mp}{q}) {
1606 @retval = $self->madness('q = Q');
1608 elsif (exists $$self{mp}{X}) {
1609 @retval = $self->madness('X');
1611 return P5AST::op_readline->new(Kids => [@retval]);
1621 if (exists $$self{mp}{q}) {
1622 @args = $self->madness('q = Q');
1624 elsif (exists $$self{mp}{X}) {
1625 @args = $self->madness('X');
1627 elsif (exists $$self{GV}) {
1630 elsif (@{$$self{Kids}}) {
1631 @args = $self->PLXML::unop::ast(@_);
1634 @args = $self->SUPER::text(@_);
1636 return $self->newtype->new(Kids => [@retval,@args]);
1640 package PLXML::op_rcatline;
1641 package PLXML::op_regcmaybe;
1642 package PLXML::op_regcreset;
1643 package PLXML::op_regcomp;
1647 $self->PLXML::unop::ast(@_);
1650 package PLXML::op_match;
1654 my $retval = $self->SUPER::ast(@_);
1656 if (not $p5re = $retval->p5text()) {
1657 $retval = $self->newtype->new(Kids => [$self->madness('X q = Q m')]);
1658 $p5re = $retval->p5text();
1660 if ($deinterpolate) {
1661 $retval->{P5re} = P5re::qrparse($p5re);
1666 package PLXML::op_qr;
1671 if (exists $$self{flags}) {
1672 $retval = $self->SUPER::ast(@_);
1675 $retval = $self->newtype->new(Kids => [$self->madness('X q = Q m')]);
1677 if ($deinterpolate) {
1678 my $p5re = $retval->p5text();
1679 $retval->{P5re} = P5re::qrparse($p5re);
1684 package PLXML::op_subst;
1689 my $bits = $self->fetchbits($$self{flags},@_);
1692 if ($bits->{binding}) {
1693 push @newkids, $bits->{binding};
1694 push @newkids, $self->madness('~');
1696 my $X = p5::token->new($$self{mp}{X});
1697 my @lfirst = $self->madness('q');
1698 my @llast = $self->madness('Q');
1701 $self->madness('E'), # XXX s/b e probably
1703 my @rfirst = $self->madness('z');
1704 my @rlast = $self->madness('Z');
1705 my @mods = $self->madness('m');
1706 if ($rfirst[-1]->uni ne $llast[-1]->uni) {
1707 push @newkids, @rfirst;
1710 push @newkids, $bits->{repl}, @rlast, @mods;
1712 my $retval = $self->newtype->new(Kids => [@newkids]);
1713 if ($deinterpolate) {
1714 my $p5re = $retval->p5text();
1715 $retval->{P5re} = P5re::qrparse($p5re);
1720 package PLXML::op_substcont;
1721 package PLXML::op_trans;
1726 # my $bits = $self->fetchbits($$self{flags},@_);
1729 my @lfirst = $self->madness('q');
1730 my @llast = $self->madness('Q');
1733 $self->madness('E'),
1735 my @rfirst = $self->madness('z');
1736 my @repl = $self->madness('R');
1737 my @rlast = $self->madness('Z');
1738 my @mods = $self->madness('m');
1739 if ($rfirst[-1]->uni ne $llast[-1]->uni) {
1740 push @newkids, @rfirst;
1743 push @newkids, @repl, @rlast, @mods;
1745 my $res = $self->newtype->new(Kids => [@newkids]);
1749 package PLXML::op_sassign;
1755 my $right = $$self{Kids}[1];
1756 eval { push @newkids, $right->ast($self, @_); };
1758 push @newkids, $self->madness('o');
1760 my $left = $$self{Kids}[0];
1761 push @newkids, $left->ast($self, @_);
1763 return $self->newtype->new(Kids => [@newkids]);
1766 package PLXML::op_aassign;
1768 sub astnull { ast(@_) }
1774 my $right = $$self{Kids}[1];
1775 push @newkids, $right->ast($self, @_);
1777 push @newkids, $self->madness('o');
1779 my $left = $$self{Kids}[0];
1780 push @newkids, $left->ast($self, @_);
1782 return $self->newtype->new(Kids => [@newkids]);
1785 package PLXML::op_chop;
1786 package PLXML::op_schop;
1787 package PLXML::op_chomp;
1788 package PLXML::op_schomp;
1789 package PLXML::op_defined;
1790 package PLXML::op_undef;
1791 package PLXML::op_study;
1792 package PLXML::op_pos;
1793 package PLXML::op_preinc;
1797 if ($$self{targ}) { # stealth post inc or dec
1798 return $self->PLXML::op_postinc::ast(@_);
1800 return $self->SUPER::ast(@_);
1803 package PLXML::op_i_preinc;
1805 sub ast { my $self = shift; $self->PLXML::op_preinc::ast(@_); }
1807 package PLXML::op_predec;
1809 sub ast { my $self = shift; $self->PLXML::op_preinc::ast(@_); }
1811 package PLXML::op_i_predec;
1813 sub ast { my $self = shift; $self->PLXML::op_preinc::ast(@_); }
1815 package PLXML::op_postinc;
1821 if (exists $$self{Kids}) {
1822 my $arg = $$self{Kids}[0];
1823 push @newkids, $arg->ast($self, @_) if defined $arg;
1825 push @newkids, $self->madness('o');
1827 my $res = $self->newtype->new(Kids => [@newkids]);
1831 package PLXML::op_i_postinc;
1833 sub ast { my $self = shift; $self->PLXML::op_postinc::ast(@_); }
1835 package PLXML::op_postdec;
1837 sub ast { my $self = shift; $self->PLXML::op_postinc::ast(@_); }
1839 package PLXML::op_i_postdec;
1841 sub ast { my $self = shift; $self->PLXML::op_postinc::ast(@_); }
1843 package PLXML::op_pow;
1844 package PLXML::op_multiply;
1845 package PLXML::op_i_multiply;
1846 package PLXML::op_divide;
1847 package PLXML::op_i_divide;
1848 package PLXML::op_modulo;
1849 package PLXML::op_i_modulo;
1850 package PLXML::op_repeat;
1854 return $self->SUPER::ast(@_)
1855 unless exists $$self{private} and $$self{private} =~ /DOLIST/;
1857 my $newself = $$self{Kids}[0]->ast($self,@_);
1858 splice @{$newself->{Kids}}, -1, 0, $self->madness('o');
1860 return bless $newself, $self->newtype; # rebless the op_null
1863 package PLXML::op_add;
1864 package PLXML::op_i_add;
1865 package PLXML::op_subtract;
1866 package PLXML::op_i_subtract;
1867 package PLXML::op_concat;
1874 if (@before = $self->madness('M')) {
1875 push @before, $self->madness('ox'); # o is the .
1878 my $left = $$self{Kids}[0];
1879 push @newkids, $left->ast($self, @_);
1881 push @newkids, $self->madness('o');
1883 my $right = $$self{Kids}[1];
1884 push @newkids, $right->ast($self, @_);
1885 return P5AST::op_concat->new(Kids => [@newkids]);
1894 if (@before = $self->madness('M')) {
1895 push @before, $self->madness('ox'); # o is the .
1898 my $left = $$self{Kids}[0];
1899 push @newkids, $left->ast($self, @_);
1901 push @newkids, $self->madness('o');
1903 my $right = $$self{Kids}[1];
1904 push @newkids, $right->ast($self, @_);
1906 return $self->newtype->new(Kids => [@before, @newkids, @after]);
1909 package PLXML::op_stringify;
1918 my @front = $self->madness('q (');
1919 my @back = $self->madness(') Q');
1920 my @M = $self->madness('M');
1922 push @newkids, $M[0], $self->madness('o');
1924 push @newkids, @front;
1925 for my $kid (@{$$self{Kids}}) {
1926 push @newkids, $kid->ast($self, @_);
1928 push @newkids, @back;
1929 return P5AST::op_stringify->new(Kids => [@newkids]);
1932 package PLXML::op_left_shift;
1933 package PLXML::op_right_shift;
1934 package PLXML::op_lt;
1935 package PLXML::op_i_lt;
1936 package PLXML::op_gt;
1937 package PLXML::op_i_gt;
1938 package PLXML::op_le;
1939 package PLXML::op_i_le;
1940 package PLXML::op_ge;
1941 package PLXML::op_i_ge;
1942 package PLXML::op_eq;
1943 package PLXML::op_i_eq;
1944 package PLXML::op_ne;
1945 package PLXML::op_i_ne;
1946 package PLXML::op_ncmp;
1947 package PLXML::op_i_ncmp;
1948 package PLXML::op_slt;
1949 package PLXML::op_sgt;
1950 package PLXML::op_sle;
1951 package PLXML::op_sge;
1952 package PLXML::op_seq;
1953 package PLXML::op_sne;
1954 package PLXML::op_scmp;
1955 package PLXML::op_bit_and;
1956 package PLXML::op_bit_xor;
1957 package PLXML::op_bit_or;
1958 package PLXML::op_negate;
1959 package PLXML::op_i_negate;
1960 package PLXML::op_not;
1964 my @newkids = $self->madness('o (');
1966 if (@newkids and $newkids[-1]->uni eq '!~') {
1971 if (exists $$self{Kids}) {
1972 my $arg = $$self{Kids}[0];
1973 push @newkids, $arg->ast($self, @_) if defined $arg;
1976 splice @{$newkids[-1][0]{Kids}}, -2, 0, @swap; # XXX WAG
1978 push @newkids, $self->madness(')');
1980 my $res = $self->newtype->new(Kids => [@newkids]);
1984 package PLXML::op_complement;
1985 package PLXML::op_atan2;
1986 package PLXML::op_sin;
1987 package PLXML::op_cos;
1988 package PLXML::op_rand;
1989 package PLXML::op_srand;
1990 package PLXML::op_exp;
1991 package PLXML::op_log;
1992 package PLXML::op_sqrt;
1993 package PLXML::op_int;
1994 package PLXML::op_hex;
1995 package PLXML::op_oct;
1996 package PLXML::op_abs;
1997 package PLXML::op_length;
1998 package PLXML::op_substr;
1999 package PLXML::op_vec;
2000 package PLXML::op_index;
2001 package PLXML::op_rindex;
2002 package PLXML::op_sprintf;
2003 package PLXML::op_formline;
2004 package PLXML::op_ord;
2005 package PLXML::op_chr;
2006 package PLXML::op_crypt;
2007 package PLXML::op_ucfirst;
2011 return $self->PLXML::listop::ast(@_);
2014 package PLXML::op_lcfirst;
2018 return $self->PLXML::listop::ast(@_);
2021 package PLXML::op_uc;
2025 return $self->PLXML::listop::ast(@_);
2028 package PLXML::op_lc;
2032 return $self->PLXML::listop::ast(@_);
2035 package PLXML::op_quotemeta;
2039 return $self->PLXML::listop::ast(@_);
2042 package PLXML::op_rv2av;
2046 return P5AST::op_rv2av->new(Kids => [$self->madness('$ @')]);
2052 if (ref $$self{Kids}[0] eq 'PLXML::op_const' and $$self{mp}{'O'}) {
2053 return $self->madness('O');
2057 push @before, $self->madness('dx d (');
2060 push @newkids, $self->madness('$ @ K');
2061 if (ref $$self{Kids}[0] ne "PLXML::op_gv") {
2062 push @newkids, $$self{Kids}[0]->ast();
2065 push @after, $self->madness(') a');
2066 return $self->newtype->new(Kids => [@before, @newkids, @after]);
2069 package PLXML::op_aelemfast;
2073 return $self->madness('$');
2076 package PLXML::op_aelem;
2081 push @newkids, $self->madness('dx d');
2082 for my $kid (@{$$self{Kids}}) {
2083 push @newkids, $kid->ast($self, @_);
2085 splice @newkids, -1, 0, $self->madness('a [');
2086 push @newkids, $self->madness(']');
2087 return P5AST::op_aelem->new(Kids => [@newkids]);
2093 my @before = $self->madness('dx d');
2095 for my $kid (@{$$self{Kids}}) {
2096 push @newkids, $kid->ast(@_);
2098 splice @newkids, -1, 0, $self->madness('a [');
2099 push @newkids, $self->madness(']');
2101 return $self->newtype->new(Kids => [@before, @newkids]);
2104 package PLXML::op_aslice;
2109 push @newkids, $self->madness('[');
2110 for my $kid (@{$$self{Kids}}) {
2111 push @newkids, $kid->ast(@_);
2113 unshift @newkids, pop @newkids;
2114 unshift @newkids, $self->madness('dx d');
2115 push @newkids, $self->madness(']');
2116 return P5AST::op_aslice->new(Kids => [@newkids]);
2123 push @newkids, $self->madness('[');
2124 for my $kid (@{$$self{Kids}}) {
2125 push @newkids, $kid->ast(@_);
2127 unshift @newkids, pop @newkids;
2128 unshift @newkids, $self->madness('dx d');
2129 push @newkids, $self->madness(']');
2131 return $self->newtype->new(Kids => [@newkids]);
2134 package PLXML::op_each;
2135 package PLXML::op_values;
2136 package PLXML::op_keys;
2137 package PLXML::op_delete;
2138 package PLXML::op_exists;
2139 package PLXML::op_rv2hv;
2143 return P5AST::op_rv2hv->new(Kids => [$self->madness('$')]);
2150 push @before, $self->madness('dx d (');
2153 push @newkids, $self->madness('$ @ % K');
2154 if (ref $$self{Kids}[0] ne "PLXML::op_gv") {
2155 push @newkids, $$self{Kids}[0]->ast();
2158 push @after, $self->madness(') a');
2159 return $self->newtype->new(Kids => [@before, @newkids, @after]);
2162 package PLXML::op_helem;
2166 local $::curstate; # hash subscript potentially a lineseq
2167 local $::curenc = $::curenc;
2170 push @newkids, $self->madness('dx d');
2171 for my $kid (@{$$self{Kids}}) {
2172 push @newkids, $kid->ast($self, @_);
2174 splice @newkids, -1, 0, $self->madness('a {');
2175 push @newkids, $self->madness('}');
2176 return P5AST::op_helem->new(Kids => [@newkids]);
2181 local $::curstate; # hash subscript potentially a lineseq
2182 local $::curenc = $::curenc;
2184 my @before = $self->madness('dx d');
2186 for my $kid (@{$$self{Kids}}) {
2187 push @newkids, $kid->ast($self, @_);
2189 splice @newkids, -1, 0, $self->madness('a {');
2190 push @newkids, $self->madness('}');
2192 return $self->newtype->new(Kids => [@before, @newkids]);
2196 package PLXML::op_hslice;
2201 push @newkids, $self->madness('{');
2202 for my $kid (@{$$self{Kids}}) {
2203 push @newkids, $kid->ast(@_);
2205 unshift @newkids, pop @newkids;
2206 unshift @newkids, $self->madness('dx d');
2207 push @newkids, $self->madness('}');
2208 return P5AST::op_hslice->new(Kids => [@newkids]);
2215 push @newkids, $self->madness('{');
2216 for my $kid (@{$$self{Kids}}) {
2217 push @newkids, $kid->ast(@_);
2219 unshift @newkids, pop @newkids;
2220 unshift @newkids, $self->madness('dx d');
2221 push @newkids, $self->madness('}');
2223 return $self->newtype->new(Kids => [@newkids]);
2226 package PLXML::op_unpack;
2227 package PLXML::op_pack;
2228 package PLXML::op_split;
2232 my $results = $self->SUPER::ast(@_);
2233 if (my @dest = $self->madness('R')) {
2234 return PLXML::op_aassign->newtype->new(Kids => [@dest, $self->madness('ox'), $results]);
2239 package PLXML::op_join;
2240 package PLXML::op_list;
2247 if (@retval = $self->madness('X')) {
2248 push @before, $self->madness('x o');
2249 return @before,@retval;
2251 my @kids = @{$$self{Kids}};
2252 for my $kid (@kids) {
2253 next if ref $kid eq 'PLXML::op_pushmark';
2254 next if ref $kid eq 'PLXML::op_null' and
2255 defined $$kid{was} and $$kid{was} eq 'pushmark';
2256 push @newkids, $kid->ast($self, @_);
2260 my @newnewkids = ();
2261 push @newnewkids, $self->madness('dx d (');
2262 push @newnewkids, @newkids;
2263 push @newnewkids, $self->madness(') :');
2264 return P5AST::op_list->new(Kids => [@newnewkids]);
2272 if (@retval = $self->madness('X')) {
2273 push @before, $self->madness('o');
2274 return $self->newtype->new(Kids => [@before,@retval]);
2276 push @retval, $self->madness('dx d (');
2279 for my $kid (@{$$self{Kids}}) {
2280 push @newkids, $kid->ast($self, @_);
2283 my @newnewkids = ();
2284 push @newnewkids, @newkids;
2285 @newkids = @newnewkids;
2286 push @retval, @newkids;
2287 push @retval, $self->madness(') :');
2288 return $self->newtype->new(Kids => [@retval]);
2291 package PLXML::op_lslice;
2297 if ($$self{mp}{q}) {
2298 push @newkids, $self->madness('q = Q');
2300 elsif ($$self{mp}{x}) {
2301 push @newkids, $self->madness('x');
2304 push @newkids, $self->madness('(');
2305 my $list = $$self{Kids}[1];
2306 push @newkids, $list->ast($self, @_);
2307 push @newkids, $self->madness(')');
2310 push @newkids, $self->madness('[');
2312 my $slice = $$self{Kids}[0];
2313 push @newkids, $slice->ast($self, @_);
2314 push @newkids, $self->madness(']');
2316 return $self->newtype->new(Kids => [@newkids]);
2319 package PLXML::op_anonlist;
2320 package PLXML::op_anonhash;
2321 package PLXML::op_splice;
2322 package PLXML::op_push;
2323 package PLXML::op_pop;
2324 package PLXML::op_shift;
2325 package PLXML::op_unshift;
2326 package PLXML::op_sort;
2327 package PLXML::op_reverse;
2331 $self->PLXML::listop::ast(@_);
2334 package PLXML::op_grepstart;
2335 package PLXML::op_grepwhile;
2336 package PLXML::op_mapstart;
2337 package PLXML::op_mapwhile;
2338 package PLXML::op_range;
2342 return $self->PLXML::binop::ast(@_);
2345 package PLXML::op_flip;
2346 package PLXML::op_flop;
2347 package PLXML::op_and;
2352 my @first = $self->madness('1');
2353 my @second = $self->madness('2');
2354 my @stuff = $$self{Kids}[0]->ast();
2355 if (my @I = $self->madness('I')) {
2358 push @newkids, $self->madness('(');
2359 push @newkids, @stuff;
2360 push @newkids, $self->madness(')');
2361 push @newkids, @second;
2365 push @newkids, $self->madness('(');
2366 push @newkids, @first;
2367 push @newkids, $self->madness(')');
2368 push @newkids, @stuff;
2371 elsif (my @i = $self->madness('i')) {
2373 push @newkids, @second;
2375 push @newkids, @stuff;
2378 push @newkids, @stuff;
2380 push @newkids, @first;
2383 elsif (my @o = $self->madness('o')) {
2385 push @newkids, @stuff;
2387 push @newkids, @second;
2390 push @newkids, @first;
2392 push @newkids, @stuff;
2395 return P5AST::op_and->new(Kids => [@newkids]);
2398 package PLXML::op_or;
2403 my @first = $self->madness('1');
2404 my @second = $self->madness('2');
2405 my @i = $self->madness('i');
2406 my @stuff = $$self{Kids}[0]->ast();
2409 push @newkids, @second;
2410 push @newkids, $self->madness('i');
2411 push @newkids, @stuff;
2414 push @newkids, @stuff;
2415 push @newkids, $self->madness('o');
2416 push @newkids, @second;
2421 push @newkids, @stuff;
2422 push @newkids, $self->madness('i');
2423 push @newkids, @first;
2426 push @newkids, @first;
2427 push @newkids, $self->madness('o');
2428 push @newkids, @stuff;
2431 return "P5AST::op_$$self{was}"->new(Kids => [@newkids]);
2435 package PLXML::op_xor;
2436 package PLXML::op_cond_expr;
2437 package PLXML::op_andassign;
2438 package PLXML::op_orassign;
2439 package PLXML::op_method;
2440 package PLXML::op_entersub;
2445 if ($$self{mp}{q}) {
2446 return $self->madness('q = Q');
2448 if ($$self{mp}{X}) { # <FH> override?
2449 return $self->madness('X');
2451 if ($$self{mp}{A}) {
2452 return $self->astmethod(@_);
2454 if ($$self{mp}{a}) {
2455 return $self->astarrow(@_);
2461 my @kids = @{$$self{Kids}};
2462 if (@kids == 1 and ref $kids[0] eq 'PLXML::op_null' and $kids[0]{was} =~ /list/) {
2463 @kids = @{$kids[0]{Kids}};
2465 my $dest = pop @kids;
2466 my @dest = $dest->ast($self, @_);
2468 if (ref($dest) =~ /method/) {
2469 my $invocant = shift @kids;
2470 $invocant = shift @kids if ref($invocant) eq 'PLXML::op_pushmark';
2471 my @invocant = $invocant->ast($self, @_);
2472 push @retval, @dest;
2473 push @retval, @invocant;
2475 elsif (exists $$self{mp}{o} and $$self{mp}{o} eq 'do') {
2476 push @retval, $self->madness('o');
2477 push @retval, @dest;
2480 push @retval, $self->madness('o');
2481 push @retval, @dest;
2484 my $kid = shift(@kids);
2485 push @newkids, $kid->ast($self, @_);
2488 push @retval, $self->madness('(');
2489 push @retval, @newkids;
2490 push @retval, $self->madness(')');
2491 return $self->newtype->new(Kids => [@retval]);
2498 for my $kid (@{$$self{Kids}}) {
2499 next if ref $kid eq 'PLXML::op_pushmark';
2500 next if ref $kid eq 'PLXML::op_null' and
2501 defined $$kid{was} and $$kid{was} eq 'pushmark';
2505 if ($$self{flags} =~ /\bSTACKED\b/) {
2506 push @invocant, shift(@kids)->ast($self, @_);
2508 for my $kid (@kids) {
2509 push @newkids, $kid->ast($self, @_);
2511 my $dest = pop(@newkids);
2512 if (ref $dest eq 'PLXML::op_rv2cv' and $$self{flags} =~ /\bMOD\b/) {
2513 $dest = pop(@newkids);
2517 push @retval, @invocant;
2518 push @retval, $self->madness('A');
2519 push @retval, $dest;
2520 push @retval, $self->madness('(');
2521 push @retval, @newkids;
2522 push @retval, $self->madness(')');
2523 return $self->newtype->new(Kids => [@retval]);
2530 my @kids = @{$$self{Kids}};
2531 if (@kids == 1 and ref $kids[0] eq 'PLXML::op_null' and $kids[0]{was} =~ /list/) {
2532 @kids = @{$kids[0]{Kids}};
2535 my $kid = shift(@kids);
2536 push @newkids, $kid->ast($self, @_);
2538 my @dest = $kids[0]->ast($self, @_);
2540 push @retval, @dest;
2541 push @retval, $self->madness('a');
2542 push @retval, $self->madness('(');
2543 push @retval, @newkids;
2544 push @retval, $self->madness(')');
2545 return $self->newtype->new(Kids => [@retval]);
2548 package PLXML::op_leavesub;
2552 if (ref $$self{Kids}[0] eq "PLXML::op_null") {
2553 return $$self{Kids}[0]->ast(@_);
2555 return $$self{Kids}[0]->blockast($self, @_);
2558 package PLXML::op_leavesublv;
2563 return $$self{Kids}[0]->blockast($self, @_);
2566 package PLXML::op_caller;
2567 package PLXML::op_warn;
2568 package PLXML::op_die;
2569 package PLXML::op_reset;
2570 package PLXML::op_lineseq;
2574 my @kids = @{$$self{Kids}};
2575 local $::curstate = 0; # (probably redundant, but that's okay)
2576 local $::prevstate = 0;
2577 local $::curenc = $::curenc;
2582 my $kid = shift @kids;
2583 my $thing = $kid->ast($self, @_);
2584 next unless defined $thing;
2585 if ($::curstate ne $::prevstate) {
2587 push @newstuff, $::prevstate->madness(';');
2588 push @{$newprev->{Kids}}, @newstuff if $newprev;
2591 $::prevstate = $::curstate;
2593 push @retval, $thing;
2595 elsif ($::prevstate) {
2596 push @newstuff, $thing;
2599 push @retval, $thing;
2603 push @newstuff, $::prevstate->madness(';');
2604 push @{$newprev->{Kids}}, @newstuff if $newprev;
2616 push @retval, $self->madness('{');
2618 my @newkids = $self->PLXML::op_lineseq::lineseq(@_);
2619 push @retval, @newkids;
2621 push @retval, $self->madness('; }');
2622 return $self->newtype->new(Kids => [@retval]);
2625 package PLXML::op_nextstate;
2627 sub newtype { return "P5AST::statement" }
2632 push @newkids, $self->madness('L');
2633 $::curstate = $self;
2634 return P5AST::statement->new(Kids => [@newkids]);
2641 push @newkids, $self->madness('L');
2642 $::curstate = $self;
2643 return $self->newtype->new(Kids => [@newkids]);
2647 package PLXML::op_dbstate;
2648 package PLXML::op_unstack;
2649 package PLXML::op_enter;
2653 package PLXML::op_leave;
2662 my $mad = $$self{mp}{FIRST} || "unknown";
2668 push @tmpkids, $self->{Kids};
2669 my $anddo = $$self{Kids}[-1]{Kids}[0]{Kids};
2670 eval { push @newkids, $anddo->[1]->ast($self,@_); };
2671 push @newkids, "[[[NOANDDO]]]" if $@;
2672 push @newkids, $self->madness('w');
2673 push @newkids, $anddo->[0]->ast($self,@_);
2675 return $self->newtype->new(Kids => [@newkids]);
2679 push @retval, $self->madness('o {');
2681 my @newkids = $self->PLXML::op_lineseq::lineseq(@_);
2682 push @retval, @newkids;
2683 push @retval, $self->madness(q/; }/);
2684 my $retval = $self->newtype->new(Kids => [@retval]);
2686 if ($$self{mp}{C}) {
2689 push @before, $self->madness('I ( C )');
2690 if ($$self{mp}{t}) {
2691 push @before, $self->madness('t');
2693 elsif ($$self{mp}{e}) {
2694 push @after, $self->madness('e');
2696 return P5AST::op_cond->new(Kids => [@before, $retval, @after]);
2703 package PLXML::op_scope;
2710 push @newkids, $self->madness('o');
2712 push @newkids, $self->madness('{');
2713 push @newkids, $self->PLXML::op_lineseq::lineseq(@_);
2714 push @newkids, $self->madness('; }');
2716 my @folded = $self->madness('C');
2718 my @t = $self->madness('t');
2719 my @e = $self->madness('e');
2721 return $self->newtype->new(
2723 $self->madness('I ('),
2725 $self->madness(')'),
2726 $self->newtype->new(Kids => [@newkids]),
2731 return $self->newtype->new(
2733 $self->madness('I ('),
2735 $self->madness(')'),
2737 $self->newtype->new(Kids => [@newkids])
2741 return $self->newtype->new(Kids => [@newkids]);
2744 package PLXML::op_enteriter;
2748 my (undef,$range,$var) = @{$self->{Kids}};
2750 push @retval, $self->madness('v');
2751 if (!@retval and defined $var) {
2752 push @retval, $var->ast($self,@_);
2757 if (ref $range eq 'PLXML::op_null' and $$self{flags} =~ /STACKED/) {
2758 my (undef,$min,$max) = @{$range->{Kids}};
2759 push @retval, $min->ast($self,@_);
2761 if (exists $$range{mp}{O}) { # deeply buried .. operator
2762 PLXML::prepreproc($$range{mp}{O});
2764 $$range{mp}{'O'}{Kids}[0]{Kids}[0]{Kids}[0]{Kids}[0]->madness('o')
2767 push @retval, '..'; # XXX missing whitespace
2769 push @retval, $max->ast($self,@_);
2773 push @retval, $range->ast($self,@_);
2775 return $self->newtype->new(Kids => [@retval]);
2778 package PLXML::op_iter;
2779 package PLXML::op_enterloop;
2784 package PLXML::op_leaveloop;
2791 my $enterloop = $$self{Kids}[0];
2792 my $nextthing = $$self{Kids}[1];
2794 if ($$self{mp}{W}) {
2795 push @retval, $self->madness('L');
2796 push @newkids, $self->madness('W d');
2798 if (ref $enterloop eq 'PLXML::op_enteriter') {
2799 my ($var,@rest) = @{$enterloop->ast($self,@_)->{Kids}};
2800 push @newkids, $var if $var;
2801 push @newkids, $self->madness('q ( x = Q');
2802 push @newkids, @rest;
2805 push @newkids, $self->madness('(');
2806 push @newkids, $enterloop->ast($self,@_);
2811 if (ref $nextthing eq 'PLXML::op_null') {
2812 if ($$nextthing{mp}{'1'}) {
2813 push @newkids, $nextthing->madness('1');
2814 push @newkids, $self->madness(')');
2815 push @newkids, $$nextthing{Kids}[0]->blockast($self,@_);
2817 elsif ($$nextthing{mp}{'2'}) {
2818 push @newkids, $$nextthing{Kids}[0]->ast($self,@_);
2819 push @newkids, $self->madness(')');
2820 push @newkids, $$nextthing{mp}{'2'}->blockast($self,@_);
2822 elsif ($$nextthing{mp}{'U'}) {
2823 push @newkids, $nextthing->ast($self,@_);
2826 # bypass the op_null
2827 $andor = $nextthing->{Kids}[0];
2829 push @newkids, $$andor{Kids}[0]->ast($self, @_);
2831 push @newkids, $self->madness(')');
2833 push @newkids, $$andor{Kids}[1]->blockast($self, @_);
2838 $andor = $nextthing;
2839 push @newkids, $nextthing->madness('O');
2840 push @newkids, $self->madness(')');
2841 push @newkids, $nextthing->blockast($self, @_);
2843 if ($$self{mp}{w}) {
2844 push @newkids, $self->madness('w');
2845 push @newkids, $enterloop->ast($self,@_);
2848 push @retval, @newkids;
2850 return $self->newtype->new(Kids => [@retval]);
2853 package PLXML::op_return;
2854 package PLXML::op_last;
2855 package PLXML::op_next;
2856 package PLXML::op_redo;
2857 package PLXML::op_dump;
2858 package PLXML::op_goto;
2859 package PLXML::op_exit;
2860 package PLXML::op_open;
2861 package PLXML::op_close;
2862 package PLXML::op_pipe_op;
2863 package PLXML::op_fileno;
2864 package PLXML::op_umask;
2865 package PLXML::op_binmode;
2866 package PLXML::op_tie;
2867 package PLXML::op_untie;
2868 package PLXML::op_tied;
2869 package PLXML::op_dbmopen;
2870 package PLXML::op_dbmclose;
2871 package PLXML::op_sselect;
2872 package PLXML::op_select;
2873 package PLXML::op_getc;
2874 package PLXML::op_read;
2875 package PLXML::op_enterwrite;
2876 package PLXML::op_leavewrite;
2877 package PLXML::op_prtf;
2878 package PLXML::op_print;
2879 package PLXML::op_sysopen;
2880 package PLXML::op_sysseek;
2881 package PLXML::op_sysread;
2882 package PLXML::op_syswrite;
2883 package PLXML::op_send;
2884 package PLXML::op_recv;
2885 package PLXML::op_eof;
2886 package PLXML::op_tell;
2887 package PLXML::op_seek;
2888 package PLXML::op_truncate;
2889 package PLXML::op_fcntl;
2890 package PLXML::op_ioctl;
2891 package PLXML::op_flock;
2892 package PLXML::op_socket;
2893 package PLXML::op_sockpair;
2894 package PLXML::op_bind;
2895 package PLXML::op_connect;
2896 package PLXML::op_listen;
2897 package PLXML::op_accept;
2898 package PLXML::op_shutdown;
2899 package PLXML::op_gsockopt;
2900 package PLXML::op_ssockopt;
2901 package PLXML::op_getsockname;
2902 package PLXML::op_getpeername;
2903 package PLXML::op_lstat;
2904 package PLXML::op_stat;
2905 package PLXML::op_ftrread;
2906 package PLXML::op_ftrwrite;
2907 package PLXML::op_ftrexec;
2908 package PLXML::op_fteread;
2909 package PLXML::op_ftewrite;
2910 package PLXML::op_fteexec;
2911 package PLXML::op_ftis;
2912 package PLXML::op_fteowned;
2913 package PLXML::op_ftrowned;
2914 package PLXML::op_ftzero;
2915 package PLXML::op_ftsize;
2916 package PLXML::op_ftmtime;
2917 package PLXML::op_ftatime;
2918 package PLXML::op_ftctime;
2919 package PLXML::op_ftsock;
2920 package PLXML::op_ftchr;
2921 package PLXML::op_ftblk;
2922 package PLXML::op_ftfile;
2923 package PLXML::op_ftdir;
2924 package PLXML::op_ftpipe;
2925 package PLXML::op_ftlink;
2926 package PLXML::op_ftsuid;
2927 package PLXML::op_ftsgid;
2928 package PLXML::op_ftsvtx;
2929 package PLXML::op_fttty;
2930 package PLXML::op_fttext;
2931 package PLXML::op_ftbinary;
2932 package PLXML::op_chdir;
2933 package PLXML::op_chown;
2934 package PLXML::op_chroot;
2935 package PLXML::op_unlink;
2936 package PLXML::op_chmod;
2937 package PLXML::op_utime;
2938 package PLXML::op_rename;
2939 package PLXML::op_link;
2940 package PLXML::op_symlink;
2941 package PLXML::op_readlink;
2942 package PLXML::op_mkdir;
2943 package PLXML::op_rmdir;
2944 package PLXML::op_open_dir;
2945 package PLXML::op_readdir;
2946 package PLXML::op_telldir;
2947 package PLXML::op_seekdir;
2948 package PLXML::op_rewinddir;
2949 package PLXML::op_closedir;
2950 package PLXML::op_fork;
2951 package PLXML::op_wait;
2952 package PLXML::op_waitpid;
2953 package PLXML::op_system;
2954 package PLXML::op_exec;
2955 package PLXML::op_kill;
2956 package PLXML::op_getppid;
2957 package PLXML::op_getpgrp;
2958 package PLXML::op_setpgrp;
2959 package PLXML::op_getpriority;
2960 package PLXML::op_setpriority;
2961 package PLXML::op_time;
2962 package PLXML::op_tms;
2963 package PLXML::op_localtime;
2964 package PLXML::op_gmtime;
2965 package PLXML::op_alarm;
2966 package PLXML::op_sleep;
2967 package PLXML::op_shmget;
2968 package PLXML::op_shmctl;
2969 package PLXML::op_shmread;
2970 package PLXML::op_shmwrite;
2971 package PLXML::op_msgget;
2972 package PLXML::op_msgctl;
2973 package PLXML::op_msgsnd;
2974 package PLXML::op_msgrcv;
2975 package PLXML::op_semget;
2976 package PLXML::op_semctl;
2977 package PLXML::op_semop;
2978 package PLXML::op_require;
2979 package PLXML::op_dofile;
2980 package PLXML::op_entereval;
2984 local $::curstate; # eval {} has own statement sequence
2985 return $self->SUPER::ast(@_);
2988 package PLXML::op_leaveeval;
2989 package PLXML::op_entertry;
2990 package PLXML::op_leavetry;
2995 return $self->PLXML::op_leave::ast(@_);
2998 package PLXML::op_ghbyname;
2999 package PLXML::op_ghbyaddr;
3000 package PLXML::op_ghostent;
3001 package PLXML::op_gnbyname;
3002 package PLXML::op_gnbyaddr;
3003 package PLXML::op_gnetent;
3004 package PLXML::op_gpbyname;
3005 package PLXML::op_gpbynumber;
3006 package PLXML::op_gprotoent;
3007 package PLXML::op_gsbyname;
3008 package PLXML::op_gsbyport;
3009 package PLXML::op_gservent;
3010 package PLXML::op_shostent;
3011 package PLXML::op_snetent;
3012 package PLXML::op_sprotoent;
3013 package PLXML::op_sservent;
3014 package PLXML::op_ehostent;
3015 package PLXML::op_enetent;
3016 package PLXML::op_eprotoent;
3017 package PLXML::op_eservent;
3018 package PLXML::op_gpwnam;
3019 package PLXML::op_gpwuid;
3020 package PLXML::op_gpwent;
3021 package PLXML::op_spwent;
3022 package PLXML::op_epwent;
3023 package PLXML::op_ggrnam;
3024 package PLXML::op_ggrgid;
3025 package PLXML::op_ggrent;
3026 package PLXML::op_sgrent;
3027 package PLXML::op_egrent;
3028 package PLXML::op_getlogin;
3029 package PLXML::op_syscall;
3030 package PLXML::op_lock;
3031 package PLXML::op_threadsv;
3032 package PLXML::op_setstate;
3033 package PLXML::op_method_named;
3037 return $self->madness('O');
3040 package PLXML::op_dor;
3044 $self->PLXML::op_or::astnull(@_);
3047 package PLXML::op_dorassign;
3048 package PLXML::op_custom;