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
13 use lib '/home/larry/src/p55';
22 while (@ARGV and $ARGV[0] =~ /^-/) {
24 if ($switch eq '-w') {
27 elsif ($switch eq '-Y') {
30 elsif ($switch eq '-d') {
34 die "Unrecognized switch: -$switch";
38 @ARGV = ('foo.xml') unless @ARGV;
43 $::curenc = 1; # start in iso-8859-1, sigh...
45 $::H = "HeredocHere000";
64 'o' => 'p5::operator',
65 '~' => 'p5::operator',
80 'a' => 'p5::operator',
81 'A' => 'p5::operator',
82 'd' => 'p5::declarator',
87 'q' => 'p5::openquote',
88 'Q' => 'p5::closequote',
92 's' => 'p5::declarator',
93 # 'V' => 'p5::version',
99 $e =~ s/\n$/\n [NODE $filename line $::prevstate->{line}]/ if $::prevstate;
104 $Data::Dumper::Indent = 1;
105 $Data::Dumper::Quotekeys = 0;
108 my $text = Dumper(@_);
109 # doesn't scale well, alas
110 1 while $text =~ s/(.*)^([^\n]*)bless\( \{\n(.*?)^(\s*\}), '([^']*)' \)([^\n]*)/$1$2$5 {\n$3$4$6 # $5/ms;
111 $text =~ s/PLXML:://g;
113 my ($package, $filename, $line) = caller;
114 my $subroutine = (caller(1))[3];
115 $text =~ s/\n?\z/, called from $subroutine, line $line\n/;
135 warn xdolist($indent,"LIST",@_);
138 my $type = ref $_[0];
140 warn xdoitem($indent,$type,@_);
143 warn xdoitem($indent,"ITEM",@_);
151 my $in = ' ' x ($indent * 2);
153 $result .= "$in<$tag>\n" if defined $tag;
155 my $itt = ref $it || "ITEM";
157 $result .= xdoitem($indent+1,$itt,$it);
159 $result .= "$in</$tag>\n" if defined $tag;
167 my $in = ' ' x ($indent * 2);
168 my $result = "$in<$tag>\n";
169 my @keys = sort keys %$hash;
172 $longest = length($k) if length($k) > $longest;
177 $K = $$hash{$k}, next if $k eq 'Kids';
178 my $sp = ' ' x ($longest - length($k));
179 if (ref $$hash{$k}) {
180 $tmp = xdoitem($indent+1,"kv",$$hash{$k});
181 $tmp =~ s!^ *<kv>\n *</kv>!$in <kv/>!;
184 $tmp = xdoitem($indent+1,"kv",$$hash{$k});
186 $k =~ s/([\t\n'"<>&])/$xmlrepl{$1}/g;
187 $tmp =~ s/<kv/<kv k='$k'$sp/ or
188 $tmp =~ s/^(.*)$/$in <kv k='$k'>\n$in $1$in <\/kv>\n/s;
192 $result .= xdolist($indent, undef, @$K);
194 $result .= "$in</$tag>\n";
201 my $in = ' ' x ($indent * 2);
204 $item =~ s/([\t\n'"<>&])/$xmlrepl{$1}/g;
205 return "$in<$tag>$item</$tag>\n";
207 (my $newtag = $r) =~ s/::/:/g;
209 if ($t =~ /\bARRAY\b/) {
211 return xdolist($indent,$tag,@{$item});
214 return "$in<$tag />\n";
217 if ($t =~ /\bHASH\b/) {
218 return xdohash($indent,$tag,$item);
221 return "$in<$newtag>$$item</$newtag>\n";
224 return "$in<$newtag type='$r'/>\n";
238 tdolist($indent,"LIST",@_);
241 my $type = ref $_[0];
243 tdoitem($indent,$type,@_);
246 tdoitem($indent,"ITEM",@_);
254 my $tag = shift || "ARRAY";
255 my $in = ' ' x ($indent * 2);
259 my $itt = ref $it || "ITEM";
260 print STDERR $in," ";
261 tdoitem($indent+1,$itt,$it);
275 my $in = ' ' x ($indent * 2);
277 print STDERR "$tag => {\n";
279 my @keys = sort keys %$hash;
282 $longest = length($k) if length($k) > $longest;
286 my $sp = ' ' x ($longest - length($k));
287 print STDERR "$in $k$sp => ";
288 tdoitem($indent+1,"",$$hash{$k});
290 print STDERR " # Kids";
294 print STDERR "$in} # $tag";
301 if (not defined $item) {
302 print STDERR "UNDEF";
305 # my $in = ' ' x ($indent * 2);
308 $item =~ s/([\t\n"])/$trepl{$1}/g;
309 print STDERR "\"$item\"";
314 my $str = $$item{uni};
315 my $enc = $enc[$$item{enc}] . ' ';
316 $enc =~ s/iso-8859-1 //;
317 $str =~ s/([\t\n"])/$trepl{$1}/g;
318 print STDERR "$r $enc\"$str\"";
320 elsif ($t =~ /\bARRAY\b/) {
321 tdolist($indent,$tag,@{$item});
323 elsif ($t =~ /\bHASH\b/) {
324 tdohash($indent,$tag,$item);
327 print STDERR "$r type='$r'";
334 if (not exists $enc{$encname}) {
336 return $enc{$encname} = $#enc;
338 return $enc{$encname};
344 my $p1 = new XML::Parser(Style => 'Objects', Pkg => 'PLXML');
345 $p1->setHandlers('Char' => sub { warn "Chars $_[1]" if $_[1] =~ /\S/; });
347 # First slurp XML into tree of objects.
349 my $root = $p1->parsefile($filename);
351 # Now turn XML tree into something more like an AST.
353 PLXML::prepreproc($root->[0]);
354 my $ast = P5AST->new('Kids' => [$root->[0]->ast()]);
359 print YAML::Syck::Dump($ast);
363 # Finally, walk AST to produce new program.
365 my $text = $ast->p5text(); # returns encoded, must output raw
375 die "Too many args to new" if @_;
376 die "Attempt to bless non-text $text" if ref $text;
377 return bless( { uni => $text,
382 sub uni { my $self = shift; $$self{uni}; } # internal stuff all in utf8
386 my $enc = $enc[$$self{enc} || 0];
387 return encode($enc, $$self{uni});
390 package p5::closequote; BEGIN { @p5::closequote::ISA = 'p5::punct'; }
391 package p5::closer; BEGIN { @p5::closer::ISA = 'p5::punct'; }
392 package p5::declarator; BEGIN { @p5::declarator::ISA = 'p5::token'; }
393 package p5::junk; BEGIN { @p5::junk::ISA = 'p5::text'; }
394 package p5::label; BEGIN { @p5::label::ISA = 'p5::token'; }
395 #package p5::name; BEGIN { @p5::name::ISA = 'p5::token'; }
396 package p5::opener; BEGIN { @p5::opener::ISA = 'p5::punct'; }
397 package p5::openquote; BEGIN { @p5::openquote::ISA = 'p5::punct'; }
398 package p5::operator; BEGIN { @p5::operator::ISA = 'p5::token'; }
399 package p5::punct; BEGIN { @p5::punct::ISA = 'p5::token'; }
400 package p5::remod; BEGIN { @p5::remod::ISA = 'p5::token'; }
401 package p5::sigil; BEGIN { @p5::sigil::ISA = 'p5::punct'; }
402 package p5::token; BEGIN { @p5::token::ISA = 'p5::text'; }
403 #package p5::version; BEGIN { @p5::version::ISA = 'p5::token'; }
405 ################################################################
406 # Routines to turn XML tree into an AST. Mostly this amounts to hoisting
407 # misplaced nodes and flattening various things into lists.
412 ::x("AUTOLOAD $PLXML::AUTOLOAD", @_);
413 return "[[[ $PLXML::AUTOLOAD ]]]";
418 my $kids = $$self{Kids};
422 for ($i = 0; $i < @$kids; $i++) {
423 if (ref $kids->[$i] eq "PLXML::madprops") {
424 $self->{mp} = splice(@$kids, $i, 1)->hash($self,@_);
429 prepreproc($kids->[$i], $self, @_);
437 if (ref $self eq 'PLXML::op_null' and $$self{was}) {
438 return "PLXML::op_$$self{was}"->key();
447 my $t = ref $self || $self;
448 $t = "PLXML::op_$$self{was}" if $t eq 'PLXML::op_null' and $$self{was};
449 $t =~ s/PLXML/P5AST/ or die "Bad type: $t";
455 my @keys = split(' ', shift);
457 for my $key (@keys) {
458 my $madprop = $self->{mp}{$key};
459 next unless defined $madprop;
460 if (ref $madprop eq 'PLXML::mad_op') {
462 push @vals, $madprop->blockast($self, @_);
465 push @vals, $madprop->ast($self, @_);
470 if ($white = $self->{mp}{"_$key"}) {
471 push @vals, p5::junk->new($white);
473 my $type = $madtype{$key} || "p5::token";
474 push @vals, $type->new($madprop);
475 if ($white = $self->{mp}{"#$key"}) {
476 push @vals, p5::junk->new($white);
491 for my $kid (@{$$self{Kids}}) {
492 push @newkids, $kid->ast($self, @_);
494 return $self->newtype->new(Kids => [uc $self->key(), "(", @newkids, ")"]);
499 my $desc = $self->desc();
500 if ($desc =~ /\((.*?)\)/) {
504 return " <<" . $self->key() . ">> ";
513 package PLXML::Characters;
515 sub ast { die "oops" }
516 sub pair { die "oops" }
518 package PLXML::madprops;
531 # We need to guarantee key uniqueness at this point.
532 for my $kid (@{$$self{Kids}}) {
533 my ($k,$v) = $kid->pair($self, @_);
535 if ($k =~ /^[_#]$/) { # rekey whitespace according to preceding entry
536 $k .= $lastthing; # (which is actually the token the whitespace is before)
539 $k .= 'x' while exists $hash{$k};
544 $hash{FIRST} = $firstthing;
545 $hash{LAST} = $lastthing;
549 package PLXML::mad_op;
553 my $key = $$self{key};
559 $self->prepreproc(@_);
561 for my $kid (@{$$self{Kids}}) {
562 push @vals, $kid->ast($self, @_);
568 return P5AST::op_list->new(Kids => [@vals]);
574 $self->prepreproc(@_);
576 for my $kid (@{$$self{Kids}}) {
577 push @vals, $kid->blockast($self, @_);
583 return P5AST::op_lineseq->new(Kids => [@vals]);
587 package PLXML::mad_pv;
591 my $key = $$self{key};
592 my $val = $$self{val};
593 $val =~ s/STUPIDXML\(#x(\w+)\)/chr(hex $1)/eg;
597 package PLXML::mad_sv;
601 my $key = $$self{key};
602 my $val = $$self{val};
603 $val =~ s/STUPIDXML\(#x(\w+)\)/chr(hex $1)/eg;
607 package PLXML::baseop;
614 push @retval, $self->madness('M ox');
615 for my $kid (@{$$self{Kids}}) {
616 push @newkids, $kid->ast($self, @_);
619 push @retval, uc $self->key(), "(", @newkids , ")";
622 push @retval, $self->madness('o ( )');
624 return $self->newtype->new(Kids => [@retval]);
627 package PLXML::baseop_unop;
631 my @newkids = $self->madness('d M ox o (');
633 if (exists $$self{Kids}) {
634 my $arg = $$self{Kids}[0];
635 push @newkids, $arg->ast($self, @_) if defined $arg;
637 push @newkids, $self->madness(')');
639 return $self->newtype()->new(Kids => [@newkids]);
642 package PLXML::binop;
648 push @newkids, $self->madness('M ox');
650 my $left = $$self{Kids}[0];
651 push @newkids, $left->ast($self, @_);
653 push @newkids, $self->madness('o');
655 my $right = $$self{Kids}[1];
656 if (defined $right) {
657 push @newkids, $right->ast($self, @_);
660 return $self->newtype->new(Kids => [@newkids]);
665 package PLXML::filestatop;
670 my @newkids = $self->madness('o (');
672 if (@{$$self{Kids}}) {
673 for my $kid (@{$$self{Kids}}) {
674 push @newkids, $kid->ast($self, @_);
678 push @newkids, $self->madness('O');
680 push @newkids, $self->madness(')');
682 return $self->newtype->new(Kids => [@newkids]);
685 package PLXML::listop;
693 if (@before = $self->madness('M')) {
694 push @before, $self->madness('ox'); # o is the function name
696 if (@retval = $self->madness('X')) {
697 push @before, $self->madness('o x');
698 return P5AST::listop->new(Kids => [@before,@retval]);
701 push @retval, $self->madness('o (');
704 for my $kid (@{$$self{Kids}}) {
705 next if ref $kid eq 'PLXML::op_pushmark';
706 next if ref $kid eq 'PLXML::op_null' and
707 defined $$kid{was} and $$kid{was} eq 'pushmark';
708 push @newkids, $kid->ast($self, @_);
714 push @retval, $self->madness('S');
716 push @retval, @newkids;
718 push @retval, $self->madness(')');
719 return $self->newtype->new(Kids => [@before,@retval,@after]);
722 package PLXML::logop;
728 push @newkids, $self->madness('o (');
729 for my $kid (@{$$self{Kids}}) {
730 push @newkids, $kid->ast($self, @_);
732 push @newkids, $self->madness(')');
733 return $self->newtype->new(Kids => [@newkids]);
738 package PLXML::loopexop;
742 my @newkids = $self->madness('o (');
744 if ($$self{mp}{L} or not $$self{flags} =~ /\bSPECIAL\b/) {
745 my @label = $self->madness('L');
747 push @newkids, @label;
750 my $arg = $$self{Kids}[0];
751 push @newkids, $arg->ast($self, @_) if defined $arg;
754 push @newkids, $self->madness(')');
756 return $self->newtype->new(Kids => [@newkids]);
760 package PLXML::padop;
762 package PLXML::padop_svop;
769 return P5AST::pmop->new(Kids => []) unless exists $$self{flags};
771 my $bits = $self->fetchbits($$self{flags},@_);
774 if ($bits->{binding}) {
775 push @newkids, $bits->{binding};
776 push @newkids, $self->madness('~');
778 if (exists $bits->{regcomp} and $bits->{regcomp}) {
779 my @front = $self->madness('q');
780 my @back = $self->madness('Q');
781 push @newkids, @front, $bits->{regcomp}, @back,
784 elsif ($$self{mp}{q}) {
785 push @newkids, $self->madness('q = Q m');
787 elsif ($$self{mp}{X}) {
788 push @newkids, $self->madness('X m');
791 push @newkids, $self->madness('e m');
794 return $self->newtype->new(Kids => [@newkids]);
800 for my $key (grep {!/^Kids/} keys %$pmop) {
801 $bits->{$key} = $pmop->{$key};
804 # Have to delete all the fake evals of the repl. This is a pain...
805 if (@{$$pmop{Kids}}) {
806 my $really = $$pmop{Kids}[0]{Kids}[0];
807 if (ref $really eq 'PLXML::op_substcont') {
808 $really = $$really{Kids}[0];
810 while ((ref $really) =~ /^PLXML::op_.*(null|entereval)/) {
811 if (exists $$really{was}) {
812 $bits->{repl} = $really->ast(@_);
815 $really = $$really{Kids}[0];
817 if (ref $really eq 'PLXML::op_scope' and
818 @{$$really{Kids}} == 1 and
819 ref $$really{Kids}[0] eq 'PLXML::op_null' and
820 not @{$$really{Kids}[0]{Kids}})
825 if (ref $really eq 'PLXML::op_leave' and
826 @{$$really{Kids}} == 2 and
827 ref $$really{Kids}[1] eq 'PLXML::op_null' and
828 not @{$$really{Kids}[1]{Kids}})
833 if ((ref $really) =~ /^PLXML::op_(scope|leave)/) {
834 # should be at inner do {...} here, so skip that fakery too
835 $bits->{repl} = $really->newtype->new(Kids => [$really->PLXML::op_lineseq::lineseq(@_)]);
836 # but retrieve the whitespace before fake '}'
837 if ($$really{mp}{'_}'}) {
838 push(@{$bits->{repl}->{Kids}}, p5::junk->new($$really{mp}{'_}'}));
841 else { # something else, padsv probably
842 $bits->{repl} = $really->ast(@_);
849 my $flags = shift || '';
851 my @kids = @{$$self{Kids}};
854 my $arg = shift @kids;
855 innerpmop($arg,\%bits, $self, @_);
856 if ($flags =~ /STACKED/) {
858 $bits{binding} = $arg->ast($self, @_);
860 if ($bits{when} ne "COMP" and @kids) {
862 $bits{regcomp} = $arg->ast($self, @_);
864 if (not exists $bits{repl} and @kids) {
866 $bits{repl} = $arg->ast($self, @_);
872 package PLXML::pvop_svop;
878 my @newkids = $self->madness('o (');
880 if (exists $$self{Kids}) {
881 my $arg = $$self{Kids}[0];
882 push @newkids, $arg->ast($self, @_) if defined $arg;
884 push @newkids, $self->madness(')');
886 return $self->newtype->new(Kids => [@newkids]);
890 package PLXML::Characters;
891 package PLXML::madprops;
892 package PLXML::mad_op;
893 package PLXML::mad_pv;
894 package PLXML::baseop;
895 package PLXML::baseop_unop;
896 package PLXML::binop;
898 package PLXML::filestatop;
899 package PLXML::listop;
900 package PLXML::logop;
902 package PLXML::loopexop;
903 package PLXML::padop;
904 package PLXML::padop_svop;
906 package PLXML::pvop_svop;
908 package PLXML::op_null;
910 # Null nodes typed by first madprop.
916 'p' => sub { # peg for #! line, etc.
919 push @newkids, $self->madness('p px');
921 return P5AST::peg->new(Kids => [@newkids])
923 '(' => sub { # extra parens around the whole thing
926 push @newkids, $self->madness('dx d o (');
927 for my $kid (@{$$self{Kids}}) {
928 push @newkids, $kid->ast($self, @_);
930 push @newkids, $self->madness(')');
931 return P5AST::parens->new(Kids => [@newkids])
933 '~' => sub { # binding operator
936 push @newkids, $$self{Kids}[0]->ast($self,@_);
937 push @newkids, $self->madness('~');
938 push @newkids, $$self{Kids}[1]->ast($self,@_);
939 return P5AST::bindop->new(Kids => [@newkids])
941 ';' => sub { # null statements/blocks
944 push @newkids, $self->madness('{ ; }');
946 return P5AST::nothing->new(Kids => [@newkids])
948 'I' => sub { # if or unless statement keyword
951 push @newkids, $self->madness('L I (');
953 for my $kid (@{$$self{Kids}}) {
954 push @subkids, $kid->ast($self, @_);
956 die "oops in op_null->new" unless @subkids == 1;
957 my $newself = $subkids[0];
958 @subkids = @{$$newself{Kids}};
960 unshift @{$subkids[0]{Kids}}, @newkids;
961 push @{$subkids[0]{Kids}}, $self->madness(')');
962 return bless($newself, 'P5AST::condstate');
967 my @module = $self->madness('U');
968 my @args = $self->madness('A');
969 my $module = $module[-1]{Kids}[-1];
970 if ($module->uni eq 'bytes') {
971 $::curenc = ::encnum('iso-8859-1');
973 elsif ($module->uni eq 'utf8') {
974 if ($$self{mp}{o} eq 'no') {
975 $::curenc = ::encnum('iso-8859-1');
978 $::curenc = ::encnum('utf-8');
981 elsif ($module->uni eq 'encoding') {
982 if ($$self{mp}{o} eq 'no') {
983 $::curenc = ::encnum('iso-8859-1');
986 $::curenc = ::encnum(eval $args[0]->p5text); # XXX bletch
989 # (Surrounding {} ends up here if use is only thing in block.)
990 push @newkids, $self->madness('{ o');
991 push @newkids, @module;
992 push @newkids, $self->madness('V');
993 push @newkids, @args;
994 push @newkids, $self->madness('S ; }');
996 return P5AST::use->new(Kids => [@newkids])
998 '?' => sub { # ternary
1002 my @condkids = @{$$self{Kids}[0]{Kids}};
1004 push @newkids, $condkids[0]->ast($self,@_), $self->madness('?');
1005 push @newkids, $condkids[1]->ast($self,@_), $self->madness(':');
1006 push @newkids, $condkids[2]->ast($self,@_);
1007 return P5AST::ternary->new(Kids => [@newkids])
1009 '&' => sub { # subroutine
1012 push @newkids, $self->madness('d n s a : { & } ;');
1014 return P5AST::sub->new(Kids => [@newkids])
1016 'i' => sub { # modifier if
1019 push @newkids, $self->madness('i');
1020 my $cond = $$self{Kids}[0];
1022 for my $kid (@{$$cond{Kids}}) {
1023 push @subkids, $kid->ast($self, @_);
1025 push @newkids, shift @subkids;
1026 unshift @newkids, @subkids;
1027 return P5AST::condmod->new(Kids => [@newkids])
1029 'P' => sub { # package declaration
1032 push @newkids, $self->madness('o');
1033 push @newkids, $self->madness('P');
1034 push @newkids, $self->madness(';');
1036 return P5AST::package->new(Kids => [@newkids])
1038 'F' => sub { # format
1040 my @newkids = $self->madness('F n b');
1042 return P5AST::format->new(Kids => [@newkids])
1044 'x' => sub { # qw literal
1046 return P5AST::qwliteral->new(Kids => [$self->madness('x')])
1048 'q' => sub { # random quote
1050 return P5AST::quote->new(Kids => [$self->madness('q = Q')])
1052 'X' => sub { # random literal
1054 return P5AST::token->new(Kids => [$self->madness('X')])
1056 ':' => sub { # attr list
1058 return P5AST::attrlist->new(Kids => [$self->madness(':')])
1060 ',' => sub { # "unary ," so to speak
1063 push @newkids, $self->madness(',');
1064 push @newkids, $$self{Kids}[0]->ast($self,@_);
1065 return P5AST::listelem->new(Kids => [@newkids])
1067 'C' => sub { # constant conditional
1070 push @newkids, $$self{Kids}[0]->ast($self,@_);
1071 my @folded = $self->madness('C');
1073 my @t = $self->madness('t');
1074 my @e = $self->madness('e');
1076 return P5AST::op_cond_expr->new(
1078 $self->madness('I ('),
1080 $self->madness(') ?'),
1081 P5AST::op_cond_expr->new(Kids => [@newkids]),
1082 $self->madness(':'),
1087 return P5AST::op_cond_expr->new(
1089 $self->madness('I ('),
1091 $self->madness(') ?'),
1093 $self->madness(':'),
1098 return P5AST::op_null->new(Kids => [@newkids])
1100 '+' => sub { # unary +
1103 push @newkids, $self->madness('+');
1104 push @newkids, $$self{Kids}[0]->ast($self,@_);
1105 return P5AST::preplus->new(Kids => [@newkids])
1107 'D' => sub { # do block
1110 push @newkids, $self->madness('D');
1111 push @newkids, $$self{Kids}[0]->ast($self,@_);
1112 return P5AST::doblock->new(Kids => [@newkids])
1114 '3' => sub { # C-style for loop
1119 my (undef, $init, $lineseq) = @{$$self{Kids}[0]{Kids}};
1120 my (undef, $leaveloop) = @{$$lineseq{Kids}};
1121 my (undef, $null) = @{$$leaveloop{Kids}};
1127 if (exists $$null{was} and $$null{was} eq 'and') {
1128 ($lineseq2) = @{$$null{Kids}};
1131 ($and) = @{$$null{Kids}};
1132 ($cond, $lineseq2) = @{$$and{Kids}};
1134 if ($$lineseq2{mp}{'{'}) {
1138 ($block, $cont) = @{$$lineseq2{Kids}};
1141 push @newkids, $self->madness('L 3 (');
1142 push @newkids, $init->ast($self,@_);
1143 push @newkids, $self->madness('1');
1144 if (defined $cond) {
1145 push @newkids, $cond->ast($self,@_);
1147 elsif (defined $null) {
1148 push @newkids, $null->madness('1');
1150 push @newkids, $self->madness('2');
1151 if (defined $cont) {
1152 push @newkids, $cont->ast($self,@_);
1154 push @newkids, $self->madness(')');
1155 push @newkids, $block->blockast($self,@_);
1157 return P5AST::cfor->new(Kids => [@newkids])
1159 'o' => sub { # random useless operator
1162 push @newkids, $self->madness('o');
1163 my $kind = $newkids[-1] || '';
1164 $kind = $kind->uni if ref $kind;
1166 for my $kid (@{$$self{Kids}}) {
1167 push @subkids, $kid->ast($self, @_);
1169 if ($kind eq '=') { # stealth readline
1170 unshift(@newkids, shift(@subkids));
1171 push(@newkids, @subkids);
1172 return P5AST::op_aassign->new(Kids => [@newkids])
1175 my $newself = $subkids[0];
1176 splice(@{$newself->{Kids}}, 1, 0,
1177 $self->madness('ox ('),
1187 # Null nodes are an untyped mess inside Perl. Instead of fixing it there,
1188 # we derive an effective type either from the "was" field or the first madprop.
1189 # (The individual routines select the actual new type.)
1193 my $was = $$self{was} || 'peg';
1194 my $mad = $$self{mp}{FIRST} || "unknown";
1196 # First try for a "was".
1197 my $meth = "PLXML::op_${was}::astnull";
1198 if (exists &{$meth}) {
1199 return $self->$meth(@_);
1202 # Look at first madprop.
1203 if (exists $astmad{$mad}) {
1204 return $astmad{$mad}->($self);
1206 warn "No mad $mad" unless $mad eq 'unknown';
1208 # Do something generic.
1210 for my $kid (@{$$self{Kids}}) {
1211 push @newkids, $kid->ast($self, @_);
1213 return $self->newtype->new(Kids => [@newkids]);
1219 local $::curenc = $::curenc;
1220 return $self->madness('{ ; }');
1223 package PLXML::op_stub;
1227 return $self->newtype->new(Kids => [$self->madness(', x ( ) q = Q')]);
1230 package PLXML::op_scalar;
1235 my @pre = $self->madness('o q');
1237 if ($op->uni =~ /^<</) {
1239 my $opstub = bless { start => $op }, 'P5AST::heredoc';
1240 push @newkids, $opstub;
1241 push @newkids, $self->madness('(');
1243 my @kids = @{$$self{Kids}};
1246 for my $kid (@kids) {
1247 next if ref $kid eq 'PLXML::op_pushmark';
1248 next if ref $kid eq 'PLXML::op_null' and
1249 defined $$kid{was} and $$kid{was} eq 'pushmark';
1250 push @divert, $kid->ast($self, @_);
1252 $opstub->{doc} = P5AST::op_list->new(Kids => [@divert]);
1253 $opstub->{end} = ($self->madness('Q'))[-1];
1255 push @newkids, $self->madness(')');
1257 return $self->newtype->new(Kids => [@pre,@newkids]);
1259 return $self->PLXML::baseop_unop::ast();
1262 package PLXML::op_pushmark;
1266 package PLXML::op_wantarray;
1267 package PLXML::op_const;
1272 return unless $$self{mp};
1273 push @newkids, $self->madness('q = Q X : f O ( )');
1274 return P5AST::op_const->new(Kids => [@newkids]);
1279 return unless %{$$self{mp}};
1284 my @args = $self->madness('f');
1287 elsif (exists $self->{mp}{q}) {
1288 push @args, $self->madness('d q');
1289 if ($args[-1]->uni =~ /^<</) {
1290 my $opstub = bless { start => pop(@args) }, 'P5AST::heredoc';
1291 $opstub->{doc} = P5AST::op_const->new(Kids => [$self->madness('=')]);
1292 $opstub->{end} = ($self->madness('Q'))[-1];
1293 push @args, $opstub;
1296 push @args, $self->madness('= Q');
1299 elsif (exists $self->{mp}{X}) {
1300 push @before, $self->madness('d'); # was local $[ probably
1301 if (not $$self{mp}{O}) {
1302 push @before, $self->madness('o'); # was unary
1304 my @X = $self->madness(': X');
1305 if (exists $$self{private} and $$self{private} =~ /BARE/) {
1306 return $self->newtype->new(Kids => [@X]);
1311 $self->madness('x'),
1313 if ($$self{mp}{O}) {
1314 push @args, $self->madness('o O');
1317 elsif (exists $self->{mp}{O}) {
1318 push @args, $self->madness('O');
1320 elsif ($$self{private} =~ /\bBARE\b/) {
1321 @args = ($$self{PV});
1323 elsif (exists $$self{mp}{o}) {
1324 @args = $self->madness('o');
1326 elsif (exists $$self{PV}) {
1327 @args = ('"', $$self{PV}, '"');
1329 elsif (exists $$self{NV}) {
1332 elsif (exists $$self{IV}) {
1336 @args = $self->SUPER::text(@_);
1338 return $self->newtype->new(Kids => [@before, @args]);
1342 package PLXML::op_gvsv;
1348 for my $attr (qw/gv GV flags/) {
1349 if (exists $$self{$attr}) {
1350 push @args, $attr, $$self{$attr};
1353 push @retval, @args;
1354 push @retval, $self->madness('X');
1355 return $self->newtype->new(Kids => [@retval]);
1358 package PLXML::op_gv;
1363 push @newkids, $self->madness('X K');
1365 return $self->newtype->new(Kids => [@newkids]);
1368 package PLXML::op_gelem;
1373 local $::curstate; # in case there are statements in subscript
1374 local $::curenc = $::curenc;
1376 push @newkids, $self->madness('dx d');
1377 for my $kid (@{$$self{Kids}}) {
1378 push @newkids, $kid->ast($self, @_);
1380 splice @newkids, -1, 0, $self->madness('o {');
1381 push @newkids, $self->madness('}');
1383 return $self->newtype->new(Kids => [@newkids]);
1386 package PLXML::op_padsv;
1391 push @args, $self->madness('dx d ( $ )');
1393 return $self->newtype->new(Kids => [@args]);
1396 package PLXML::op_padav;
1398 sub astnull { ast(@_) }
1403 push @retval, $self->madness('dx d (');
1404 push @retval, $self->madness('$ @');
1405 push @retval, $self->madness(') o O');
1406 return $self->newtype->new(Kids => [@retval]);
1409 package PLXML::op_padhv;
1411 sub astnull { ast(@_) }
1416 push @retval, $self->madness('dx d (');
1417 push @retval, $self->madness('$ @ %');
1418 push @retval, $self->madness(') o O');
1419 return $self->newtype->new(Kids => [@retval]);
1422 package PLXML::op_padany;
1424 package PLXML::op_pushre;
1428 if ($$self{mp}{q}) {
1429 return $self->madness('q = Q m');
1431 if ($$self{mp}{X}) {
1432 return $self->madness('X m');
1434 if ($$self{mp}{e}) {
1435 return $self->madness('e m');
1437 return $$self{Kids}[1]->ast($self,@_), $self->madness('m');
1440 package PLXML::op_rv2gv;
1446 push @newkids, $self->madness('dx d ( * $');
1447 push @newkids, $$self{Kids}[0]->ast();
1448 push @newkids, $self->madness(')');
1449 return $self->newtype->new(Kids => [@newkids]);
1452 package PLXML::op_rv2sv;
1456 return P5AST::op_rv2sv->new(Kids => [$self->madness('O o dx d ( $ ) : a')]);
1463 push @newkids, $self->madness('dx d ( $');
1464 if (ref $$self{Kids}[0] ne "PLXML::op_gv") {
1465 push @newkids, $$self{Kids}[0]->ast();
1467 push @newkids, $self->madness(') : a');
1468 return $self->newtype->new(Kids => [@newkids]);
1471 package PLXML::op_av2arylen;
1477 push @newkids, $$self{Kids}[0]->madness('l');
1478 push @newkids, $$self{Kids}[0]->ast();
1479 return $self->newtype->new(Kids => [@newkids]);
1482 package PLXML::op_rv2cv;
1487 push @newkids, $self->madness('X');
1488 return @newkids if @newkids;
1489 if (exists $$self{mp}{'&'}) {
1490 push @newkids, $self->madness('&');
1491 if (@{$$self{Kids}}) {
1492 push @newkids, $$self{Kids}[0]->ast(@_);
1496 push @newkids, $$self{Kids}[0]->ast(@_);
1498 return P5AST::op_rv2cv->new(Kids => [@newkids]);
1505 push @newkids, $self->madness('&');
1506 if (@{$$self{Kids}}) {
1507 push @newkids, $$self{Kids}[0]->ast();
1509 return $self->newtype->new(Kids => [@newkids]);
1512 package PLXML::op_anoncode;
1516 my $arg = $$self{Kids}[0];
1517 local $::curstate; # hide nested statements in sub
1518 local $::curenc = $::curenc;
1520 return $arg->ast(@_);
1522 return ';'; # XXX literal ; should come through somewhere
1525 package PLXML::op_prototype;
1526 package PLXML::op_refgen;
1530 my @newkids = $self->madness('o s a');
1532 if (exists $$self{Kids}) {
1533 my $arg = $$self{Kids}[0];
1534 push @newkids, $arg->ast($self, @_) if defined $arg;
1537 my $res = $self->newtype->new(Kids => [@newkids]);
1541 package PLXML::op_srefgen;
1546 if ($$self{mp}{FIRST} eq '{') {
1547 local $::curstate; # this is officially a block, so hide it
1548 local $::curenc = $::curenc;
1549 push @newkids, $self->madness('{');
1550 for my $kid (@{$$self{Kids}}) {
1551 push @newkids, $kid->ast($self, @_);
1553 push @newkids, $self->madness('; }');
1554 return P5AST::op_stringify->new(Kids => [@newkids]);
1557 push @newkids, $self->madness('o [');
1558 for my $kid (@{$$self{Kids}}) {
1559 push @newkids, $kid->ast($self, @_);
1561 push @newkids, $self->madness(']');
1562 return P5AST::op_stringify->new(Kids => [@newkids]);
1566 package PLXML::op_ref;
1567 package PLXML::op_bless;
1568 package PLXML::op_backtick;
1573 if (exists $self->{mp}{q}) {
1574 push @args, $self->madness('q');
1575 if ($args[-1]->uni =~ /^<</) {
1576 my $opstub = bless { start => $args[-1] }, 'P5AST::heredoc';
1577 $args[-1] = $opstub;
1578 $opstub->{doc} = P5AST::op_const->new(Kids => [$self->madness('=')]);
1579 $opstub->{end} = ($self->madness('Q'))[-1];
1582 push @args, $self->madness('= Q');
1585 return $self->newtype->new(Kids => [@args]);
1588 package PLXML::op_glob;
1592 my @retval = $self->madness('o q = Q');
1593 if (not @retval or $retval[-1]->uni eq 'glob') {
1594 push @retval, $self->madness('(');
1595 push @retval, $$self{Kids}[0]->ast($self,@_);
1596 push @retval, $self->madness(')');
1598 return P5AST::op_glob->new(Kids => [@retval]);
1601 package PLXML::op_readline;
1606 if (exists $$self{mp}{q}) {
1607 @retval = $self->madness('q = Q');
1609 elsif (exists $$self{mp}{X}) {
1610 @retval = $self->madness('X');
1612 return P5AST::op_readline->new(Kids => [@retval]);
1622 if (exists $$self{mp}{q}) {
1623 @args = $self->madness('q = Q');
1625 elsif (exists $$self{mp}{X}) {
1626 @args = $self->madness('X');
1628 elsif (exists $$self{GV}) {
1631 elsif (@{$$self{Kids}}) {
1632 @args = $self->PLXML::unop::ast(@_);
1635 @args = $self->SUPER::text(@_);
1637 return $self->newtype->new(Kids => [@retval,@args]);
1641 package PLXML::op_rcatline;
1642 package PLXML::op_regcmaybe;
1643 package PLXML::op_regcreset;
1644 package PLXML::op_regcomp;
1648 $self->PLXML::unop::ast(@_);
1651 package PLXML::op_match;
1655 my $retval = $self->SUPER::ast(@_);
1657 if (not $p5re = $retval->p5text()) {
1658 $retval = $self->newtype->new(Kids => [$self->madness('X q = Q m')]);
1659 $p5re = $retval->p5text();
1661 if ($deinterpolate) {
1662 $retval->{P5re} = P5re::qrparse($p5re);
1667 package PLXML::op_qr;
1672 if (exists $$self{flags}) {
1673 $retval = $self->SUPER::ast(@_);
1676 $retval = $self->newtype->new(Kids => [$self->madness('X q = Q m')]);
1678 if ($deinterpolate) {
1679 my $p5re = $retval->p5text();
1680 $retval->{P5re} = P5re::qrparse($p5re);
1685 package PLXML::op_subst;
1690 my $bits = $self->fetchbits($$self{flags},@_);
1693 if ($bits->{binding}) {
1694 push @newkids, $bits->{binding};
1695 push @newkids, $self->madness('~');
1697 my $X = p5::token->new($$self{mp}{X});
1698 my @lfirst = $self->madness('q');
1699 my @llast = $self->madness('Q');
1702 $self->madness('E'), # XXX s/b e probably
1704 my @rfirst = $self->madness('z');
1705 my @rlast = $self->madness('Z');
1706 my @mods = $self->madness('m');
1707 if ($rfirst[-1]->uni ne $llast[-1]->uni) {
1708 push @newkids, @rfirst;
1711 push @newkids, $bits->{repl}, @rlast, @mods;
1713 my $retval = $self->newtype->new(Kids => [@newkids]);
1714 if ($deinterpolate) {
1715 my $p5re = $retval->p5text();
1716 $retval->{P5re} = P5re::qrparse($p5re);
1721 package PLXML::op_substcont;
1722 package PLXML::op_trans;
1727 # my $bits = $self->fetchbits($$self{flags},@_);
1730 my @lfirst = $self->madness('q');
1731 my @llast = $self->madness('Q');
1734 $self->madness('E'),
1736 my @rfirst = $self->madness('z');
1737 my @repl = $self->madness('R');
1738 my @rlast = $self->madness('Z');
1739 my @mods = $self->madness('m');
1740 if ($rfirst[-1]->uni ne $llast[-1]->uni) {
1741 push @newkids, @rfirst;
1744 push @newkids, @repl, @rlast, @mods;
1746 my $res = $self->newtype->new(Kids => [@newkids]);
1750 package PLXML::op_sassign;
1756 my $right = $$self{Kids}[1];
1757 eval { push @newkids, $right->ast($self, @_); };
1759 push @newkids, $self->madness('o');
1761 my $left = $$self{Kids}[0];
1762 push @newkids, $left->ast($self, @_);
1764 return $self->newtype->new(Kids => [@newkids]);
1767 package PLXML::op_aassign;
1769 sub astnull { ast(@_) }
1775 my $right = $$self{Kids}[1];
1776 push @newkids, $right->ast($self, @_);
1778 push @newkids, $self->madness('o');
1780 my $left = $$self{Kids}[0];
1781 push @newkids, $left->ast($self, @_);
1783 return $self->newtype->new(Kids => [@newkids]);
1786 package PLXML::op_chop;
1787 package PLXML::op_schop;
1788 package PLXML::op_chomp;
1789 package PLXML::op_schomp;
1790 package PLXML::op_defined;
1791 package PLXML::op_undef;
1792 package PLXML::op_study;
1793 package PLXML::op_pos;
1794 package PLXML::op_preinc;
1798 if ($$self{targ}) { # stealth post inc or dec
1799 return $self->PLXML::op_postinc::ast(@_);
1801 return $self->SUPER::ast(@_);
1804 package PLXML::op_i_preinc;
1806 sub ast { my $self = shift; $self->PLXML::op_preinc::ast(@_); }
1808 package PLXML::op_predec;
1810 sub ast { my $self = shift; $self->PLXML::op_preinc::ast(@_); }
1812 package PLXML::op_i_predec;
1814 sub ast { my $self = shift; $self->PLXML::op_preinc::ast(@_); }
1816 package PLXML::op_postinc;
1822 if (exists $$self{Kids}) {
1823 my $arg = $$self{Kids}[0];
1824 push @newkids, $arg->ast($self, @_) if defined $arg;
1826 push @newkids, $self->madness('o');
1828 my $res = $self->newtype->new(Kids => [@newkids]);
1832 package PLXML::op_i_postinc;
1834 sub ast { my $self = shift; $self->PLXML::op_postinc::ast(@_); }
1836 package PLXML::op_postdec;
1838 sub ast { my $self = shift; $self->PLXML::op_postinc::ast(@_); }
1840 package PLXML::op_i_postdec;
1842 sub ast { my $self = shift; $self->PLXML::op_postinc::ast(@_); }
1844 package PLXML::op_pow;
1845 package PLXML::op_multiply;
1846 package PLXML::op_i_multiply;
1847 package PLXML::op_divide;
1848 package PLXML::op_i_divide;
1849 package PLXML::op_modulo;
1850 package PLXML::op_i_modulo;
1851 package PLXML::op_repeat;
1855 return $self->SUPER::ast(@_)
1856 unless exists $$self{private} and $$self{private} =~ /DOLIST/;
1858 my $newself = $$self{Kids}[0]->ast($self,@_);
1859 splice @{$newself->{Kids}}, -1, 0, $self->madness('o');
1861 return bless $newself, $self->newtype; # rebless the op_null
1864 package PLXML::op_add;
1865 package PLXML::op_i_add;
1866 package PLXML::op_subtract;
1867 package PLXML::op_i_subtract;
1868 package PLXML::op_concat;
1875 if (@before = $self->madness('M')) {
1876 push @before, $self->madness('ox'); # o is the .
1879 my $left = $$self{Kids}[0];
1880 push @newkids, $left->ast($self, @_);
1882 push @newkids, $self->madness('o');
1884 my $right = $$self{Kids}[1];
1885 push @newkids, $right->ast($self, @_);
1886 return P5AST::op_concat->new(Kids => [@newkids]);
1895 if (@before = $self->madness('M')) {
1896 push @before, $self->madness('ox'); # o is the .
1899 my $left = $$self{Kids}[0];
1900 push @newkids, $left->ast($self, @_);
1902 push @newkids, $self->madness('o');
1904 my $right = $$self{Kids}[1];
1905 push @newkids, $right->ast($self, @_);
1907 return $self->newtype->new(Kids => [@before, @newkids, @after]);
1910 package PLXML::op_stringify;
1919 my @front = $self->madness('q (');
1920 my @back = $self->madness(') Q');
1921 my @M = $self->madness('M');
1923 push @newkids, $M[0], $self->madness('o');
1925 push @newkids, @front;
1926 for my $kid (@{$$self{Kids}}) {
1927 push @newkids, $kid->ast($self, @_);
1929 push @newkids, @back;
1930 return P5AST::op_stringify->new(Kids => [@newkids]);
1933 package PLXML::op_left_shift;
1934 package PLXML::op_right_shift;
1935 package PLXML::op_lt;
1936 package PLXML::op_i_lt;
1937 package PLXML::op_gt;
1938 package PLXML::op_i_gt;
1939 package PLXML::op_le;
1940 package PLXML::op_i_le;
1941 package PLXML::op_ge;
1942 package PLXML::op_i_ge;
1943 package PLXML::op_eq;
1944 package PLXML::op_i_eq;
1945 package PLXML::op_ne;
1946 package PLXML::op_i_ne;
1947 package PLXML::op_ncmp;
1948 package PLXML::op_i_ncmp;
1949 package PLXML::op_slt;
1950 package PLXML::op_sgt;
1951 package PLXML::op_sle;
1952 package PLXML::op_sge;
1953 package PLXML::op_seq;
1954 package PLXML::op_sne;
1955 package PLXML::op_scmp;
1956 package PLXML::op_bit_and;
1957 package PLXML::op_bit_xor;
1958 package PLXML::op_bit_or;
1959 package PLXML::op_negate;
1960 package PLXML::op_i_negate;
1961 package PLXML::op_not;
1965 my @newkids = $self->madness('o (');
1967 if (@newkids and $newkids[-1]->uni eq '!~') {
1972 if (exists $$self{Kids}) {
1973 my $arg = $$self{Kids}[0];
1974 push @newkids, $arg->ast($self, @_) if defined $arg;
1977 splice @{$newkids[-1][0]{Kids}}, -2, 0, @swap; # XXX WAG
1979 push @newkids, $self->madness(')');
1981 my $res = $self->newtype->new(Kids => [@newkids]);
1985 package PLXML::op_complement;
1986 package PLXML::op_atan2;
1987 package PLXML::op_sin;
1988 package PLXML::op_cos;
1989 package PLXML::op_rand;
1990 package PLXML::op_srand;
1991 package PLXML::op_exp;
1992 package PLXML::op_log;
1993 package PLXML::op_sqrt;
1994 package PLXML::op_int;
1995 package PLXML::op_hex;
1996 package PLXML::op_oct;
1997 package PLXML::op_abs;
1998 package PLXML::op_length;
1999 package PLXML::op_substr;
2000 package PLXML::op_vec;
2001 package PLXML::op_index;
2002 package PLXML::op_rindex;
2003 package PLXML::op_sprintf;
2004 package PLXML::op_formline;
2005 package PLXML::op_ord;
2006 package PLXML::op_chr;
2007 package PLXML::op_crypt;
2008 package PLXML::op_ucfirst;
2012 return $self->PLXML::listop::ast(@_);
2015 package PLXML::op_lcfirst;
2019 return $self->PLXML::listop::ast(@_);
2022 package PLXML::op_uc;
2026 return $self->PLXML::listop::ast(@_);
2029 package PLXML::op_lc;
2033 return $self->PLXML::listop::ast(@_);
2036 package PLXML::op_quotemeta;
2040 return $self->PLXML::listop::ast(@_);
2043 package PLXML::op_rv2av;
2047 return P5AST::op_rv2av->new(Kids => [$self->madness('$ @')]);
2053 if (ref $$self{Kids}[0] eq 'PLXML::op_const' and $$self{mp}{'O'}) {
2054 return $self->madness('O');
2058 push @before, $self->madness('dx d (');
2061 push @newkids, $self->madness('$ @ K');
2062 if (ref $$self{Kids}[0] ne "PLXML::op_gv") {
2063 push @newkids, $$self{Kids}[0]->ast();
2066 push @after, $self->madness(') a');
2067 return $self->newtype->new(Kids => [@before, @newkids, @after]);
2070 package PLXML::op_aelemfast;
2074 return $self->madness('$');
2077 package PLXML::op_aelem;
2082 push @newkids, $self->madness('dx d');
2083 for my $kid (@{$$self{Kids}}) {
2084 push @newkids, $kid->ast($self, @_);
2086 splice @newkids, -1, 0, $self->madness('a [');
2087 push @newkids, $self->madness(']');
2088 return P5AST::op_aelem->new(Kids => [@newkids]);
2094 my @before = $self->madness('dx d');
2096 for my $kid (@{$$self{Kids}}) {
2097 push @newkids, $kid->ast(@_);
2099 splice @newkids, -1, 0, $self->madness('a [');
2100 push @newkids, $self->madness(']');
2102 return $self->newtype->new(Kids => [@before, @newkids]);
2105 package PLXML::op_aslice;
2110 push @newkids, $self->madness('[');
2111 for my $kid (@{$$self{Kids}}) {
2112 push @newkids, $kid->ast(@_);
2114 unshift @newkids, pop @newkids;
2115 unshift @newkids, $self->madness('dx d');
2116 push @newkids, $self->madness(']');
2117 return P5AST::op_aslice->new(Kids => [@newkids]);
2124 push @newkids, $self->madness('[');
2125 for my $kid (@{$$self{Kids}}) {
2126 push @newkids, $kid->ast(@_);
2128 unshift @newkids, pop @newkids;
2129 unshift @newkids, $self->madness('dx d');
2130 push @newkids, $self->madness(']');
2132 return $self->newtype->new(Kids => [@newkids]);
2135 package PLXML::op_each;
2136 package PLXML::op_values;
2137 package PLXML::op_keys;
2138 package PLXML::op_delete;
2139 package PLXML::op_exists;
2140 package PLXML::op_rv2hv;
2144 return P5AST::op_rv2hv->new(Kids => [$self->madness('$')]);
2151 push @before, $self->madness('dx d (');
2154 push @newkids, $self->madness('$ @ % K');
2155 if (ref $$self{Kids}[0] ne "PLXML::op_gv") {
2156 push @newkids, $$self{Kids}[0]->ast();
2159 push @after, $self->madness(') a');
2160 return $self->newtype->new(Kids => [@before, @newkids, @after]);
2163 package PLXML::op_helem;
2167 local $::curstate; # hash subscript potentially a lineseq
2168 local $::curenc = $::curenc;
2171 push @newkids, $self->madness('dx d');
2172 for my $kid (@{$$self{Kids}}) {
2173 push @newkids, $kid->ast($self, @_);
2175 splice @newkids, -1, 0, $self->madness('a {');
2176 push @newkids, $self->madness('}');
2177 return P5AST::op_helem->new(Kids => [@newkids]);
2182 local $::curstate; # hash subscript potentially a lineseq
2183 local $::curenc = $::curenc;
2185 my @before = $self->madness('dx d');
2187 for my $kid (@{$$self{Kids}}) {
2188 push @newkids, $kid->ast($self, @_);
2190 splice @newkids, -1, 0, $self->madness('a {');
2191 push @newkids, $self->madness('}');
2193 return $self->newtype->new(Kids => [@before, @newkids]);
2197 package PLXML::op_hslice;
2202 push @newkids, $self->madness('{');
2203 for my $kid (@{$$self{Kids}}) {
2204 push @newkids, $kid->ast(@_);
2206 unshift @newkids, pop @newkids;
2207 unshift @newkids, $self->madness('dx d');
2208 push @newkids, $self->madness('}');
2209 return P5AST::op_hslice->new(Kids => [@newkids]);
2216 push @newkids, $self->madness('{');
2217 for my $kid (@{$$self{Kids}}) {
2218 push @newkids, $kid->ast(@_);
2220 unshift @newkids, pop @newkids;
2221 unshift @newkids, $self->madness('dx d');
2222 push @newkids, $self->madness('}');
2224 return $self->newtype->new(Kids => [@newkids]);
2227 package PLXML::op_unpack;
2228 package PLXML::op_pack;
2229 package PLXML::op_split;
2233 my $results = $self->SUPER::ast(@_);
2234 if (my @dest = $self->madness('R')) {
2235 return PLXML::op_aassign->newtype->new(Kids => [@dest, $self->madness('ox'), $results]);
2240 package PLXML::op_join;
2241 package PLXML::op_list;
2248 if (@retval = $self->madness('X')) {
2249 push @before, $self->madness('x o');
2250 return @before,@retval;
2252 my @kids = @{$$self{Kids}};
2253 for my $kid (@kids) {
2254 next if ref $kid eq 'PLXML::op_pushmark';
2255 next if ref $kid eq 'PLXML::op_null' and
2256 defined $$kid{was} and $$kid{was} eq 'pushmark';
2257 push @newkids, $kid->ast($self, @_);
2261 my @newnewkids = ();
2262 push @newnewkids, $self->madness('dx d (');
2263 push @newnewkids, @newkids;
2264 push @newnewkids, $self->madness(') :');
2265 return P5AST::op_list->new(Kids => [@newnewkids]);
2273 if (@retval = $self->madness('X')) {
2274 push @before, $self->madness('o');
2275 return $self->newtype->new(Kids => [@before,@retval]);
2277 push @retval, $self->madness('dx d (');
2280 for my $kid (@{$$self{Kids}}) {
2281 push @newkids, $kid->ast($self, @_);
2284 my @newnewkids = ();
2285 push @newnewkids, @newkids;
2286 @newkids = @newnewkids;
2287 push @retval, @newkids;
2288 push @retval, $self->madness(') :');
2289 return $self->newtype->new(Kids => [@retval]);
2292 package PLXML::op_lslice;
2298 if ($$self{mp}{q}) {
2299 push @newkids, $self->madness('q = Q');
2301 elsif ($$self{mp}{x}) {
2302 push @newkids, $self->madness('x');
2305 push @newkids, $self->madness('(');
2306 my $list = $$self{Kids}[1];
2307 push @newkids, $list->ast($self, @_);
2308 push @newkids, $self->madness(')');
2311 push @newkids, $self->madness('[');
2313 my $slice = $$self{Kids}[0];
2314 push @newkids, $slice->ast($self, @_);
2315 push @newkids, $self->madness(']');
2317 return $self->newtype->new(Kids => [@newkids]);
2320 package PLXML::op_anonlist;
2321 package PLXML::op_anonhash;
2322 package PLXML::op_splice;
2323 package PLXML::op_push;
2324 package PLXML::op_pop;
2325 package PLXML::op_shift;
2326 package PLXML::op_unshift;
2327 package PLXML::op_sort;
2328 package PLXML::op_reverse;
2332 $self->PLXML::listop::ast(@_);
2335 package PLXML::op_grepstart;
2336 package PLXML::op_grepwhile;
2337 package PLXML::op_mapstart;
2338 package PLXML::op_mapwhile;
2339 package PLXML::op_range;
2343 return $self->PLXML::binop::ast(@_);
2346 package PLXML::op_flip;
2347 package PLXML::op_flop;
2348 package PLXML::op_and;
2353 my @first = $self->madness('1');
2354 my @second = $self->madness('2');
2355 my @stuff = $$self{Kids}[0]->ast();
2356 if (my @I = $self->madness('I')) {
2359 push @newkids, $self->madness('(');
2360 push @newkids, @stuff;
2361 push @newkids, $self->madness(')');
2362 push @newkids, @second;
2366 push @newkids, $self->madness('(');
2367 push @newkids, @first;
2368 push @newkids, $self->madness(')');
2369 push @newkids, @stuff;
2372 elsif (my @i = $self->madness('i')) {
2374 push @newkids, @second;
2376 push @newkids, @stuff;
2379 push @newkids, @stuff;
2381 push @newkids, @first;
2384 elsif (my @o = $self->madness('o')) {
2386 push @newkids, @stuff;
2388 push @newkids, @second;
2391 push @newkids, @first;
2393 push @newkids, @stuff;
2396 return P5AST::op_and->new(Kids => [@newkids]);
2399 package PLXML::op_or;
2404 my @first = $self->madness('1');
2405 my @second = $self->madness('2');
2406 my @i = $self->madness('i');
2407 my @stuff = $$self{Kids}[0]->ast();
2410 push @newkids, @second;
2411 push @newkids, $self->madness('i');
2412 push @newkids, @stuff;
2415 push @newkids, @stuff;
2416 push @newkids, $self->madness('o');
2417 push @newkids, @second;
2422 push @newkids, @stuff;
2423 push @newkids, $self->madness('i');
2424 push @newkids, @first;
2427 push @newkids, @first;
2428 push @newkids, $self->madness('o');
2429 push @newkids, @stuff;
2432 return "P5AST::op_$$self{was}"->new(Kids => [@newkids]);
2436 package PLXML::op_xor;
2437 package PLXML::op_cond_expr;
2438 package PLXML::op_andassign;
2439 package PLXML::op_orassign;
2440 package PLXML::op_method;
2441 package PLXML::op_entersub;
2446 if ($$self{mp}{q}) {
2447 return $self->madness('q = Q');
2449 if ($$self{mp}{X}) { # <FH> override?
2450 return $self->madness('X');
2452 if ($$self{mp}{A}) {
2453 return $self->astmethod(@_);
2455 if ($$self{mp}{a}) {
2456 return $self->astarrow(@_);
2462 my @kids = @{$$self{Kids}};
2463 if (@kids == 1 and ref $kids[0] eq 'PLXML::op_null' and $kids[0]{was} =~ /list/) {
2464 @kids = @{$kids[0]{Kids}};
2466 my $dest = pop @kids;
2467 my @dest = $dest->ast($self, @_);
2469 if (ref($dest) =~ /method/) {
2470 my $invocant = shift @kids;
2471 $invocant = shift @kids if ref($invocant) eq 'PLXML::op_pushmark';
2472 my @invocant = $invocant->ast($self, @_);
2473 push @retval, @dest;
2474 push @retval, @invocant;
2476 elsif (exists $$self{mp}{o} and $$self{mp}{o} eq 'do') {
2477 push @retval, $self->madness('o');
2478 push @retval, @dest;
2481 push @retval, $self->madness('o');
2482 push @retval, @dest;
2485 my $kid = shift(@kids);
2486 push @newkids, $kid->ast($self, @_);
2489 push @retval, $self->madness('(');
2490 push @retval, @newkids;
2491 push @retval, $self->madness(')');
2492 return $self->newtype->new(Kids => [@retval]);
2499 for my $kid (@{$$self{Kids}}) {
2500 next if ref $kid eq 'PLXML::op_pushmark';
2501 next if ref $kid eq 'PLXML::op_null' and
2502 defined $$kid{was} and $$kid{was} eq 'pushmark';
2506 if ($$self{flags} =~ /\bSTACKED\b/) {
2507 push @invocant, shift(@kids)->ast($self, @_);
2509 for my $kid (@kids) {
2510 push @newkids, $kid->ast($self, @_);
2512 my $dest = pop(@newkids);
2513 if (ref $dest eq 'PLXML::op_rv2cv' and $$self{flags} =~ /\bMOD\b/) {
2514 $dest = pop(@newkids);
2518 push @retval, @invocant;
2519 push @retval, $self->madness('A');
2520 push @retval, $dest;
2521 push @retval, $self->madness('(');
2522 push @retval, @newkids;
2523 push @retval, $self->madness(')');
2524 return $self->newtype->new(Kids => [@retval]);
2531 my @kids = @{$$self{Kids}};
2532 if (@kids == 1 and ref $kids[0] eq 'PLXML::op_null' and $kids[0]{was} =~ /list/) {
2533 @kids = @{$kids[0]{Kids}};
2536 my $kid = shift(@kids);
2537 push @newkids, $kid->ast($self, @_);
2539 my @dest = $kids[0]->ast($self, @_);
2541 push @retval, @dest;
2542 push @retval, $self->madness('a');
2543 push @retval, $self->madness('(');
2544 push @retval, @newkids;
2545 push @retval, $self->madness(')');
2546 return $self->newtype->new(Kids => [@retval]);
2549 package PLXML::op_leavesub;
2553 if (ref $$self{Kids}[0] eq "PLXML::op_null") {
2554 return $$self{Kids}[0]->ast(@_);
2556 return $$self{Kids}[0]->blockast($self, @_);
2559 package PLXML::op_leavesublv;
2564 return $$self{Kids}[0]->blockast($self, @_);
2567 package PLXML::op_caller;
2568 package PLXML::op_warn;
2569 package PLXML::op_die;
2570 package PLXML::op_reset;
2571 package PLXML::op_lineseq;
2575 my @kids = @{$$self{Kids}};
2576 local $::curstate = 0; # (probably redundant, but that's okay)
2577 local $::prevstate = 0;
2578 local $::curenc = $::curenc;
2583 my $kid = shift @kids;
2584 my $thing = $kid->ast($self, @_);
2585 next unless defined $thing;
2586 if ($::curstate ne $::prevstate) {
2588 push @newstuff, $::prevstate->madness(';');
2589 push @{$newprev->{Kids}}, @newstuff if $newprev;
2592 $::prevstate = $::curstate;
2594 push @retval, $thing;
2596 elsif ($::prevstate) {
2597 push @newstuff, $thing;
2600 push @retval, $thing;
2604 push @newstuff, $::prevstate->madness(';');
2605 push @{$newprev->{Kids}}, @newstuff if $newprev;
2617 push @retval, $self->madness('{');
2619 my @newkids = $self->PLXML::op_lineseq::lineseq(@_);
2620 push @retval, @newkids;
2622 push @retval, $self->madness('; }');
2623 return $self->newtype->new(Kids => [@retval]);
2626 package PLXML::op_nextstate;
2628 sub newtype { return "P5AST::statement" }
2633 push @newkids, $self->madness('L');
2634 $::curstate = $self;
2635 return P5AST::statement->new(Kids => [@newkids]);
2642 push @newkids, $self->madness('L');
2643 $::curstate = $self;
2644 return $self->newtype->new(Kids => [@newkids]);
2648 package PLXML::op_dbstate;
2649 package PLXML::op_unstack;
2650 package PLXML::op_enter;
2654 package PLXML::op_leave;
2663 my $mad = $$self{mp}{FIRST} || "unknown";
2669 push @tmpkids, $self->{Kids};
2670 my $anddo = $$self{Kids}[-1]{Kids}[0]{Kids};
2671 eval { push @newkids, $anddo->[1]->ast($self,@_); };
2672 push @newkids, "[[[NOANDDO]]]" if $@;
2673 push @newkids, $self->madness('w');
2674 push @newkids, $anddo->[0]->ast($self,@_);
2676 return $self->newtype->new(Kids => [@newkids]);
2680 push @retval, $self->madness('o {');
2682 my @newkids = $self->PLXML::op_lineseq::lineseq(@_);
2683 push @retval, @newkids;
2684 push @retval, $self->madness(q/; }/);
2685 my $retval = $self->newtype->new(Kids => [@retval]);
2687 if ($$self{mp}{C}) {
2690 push @before, $self->madness('I ( C )');
2691 if ($$self{mp}{t}) {
2692 push @before, $self->madness('t');
2694 elsif ($$self{mp}{e}) {
2695 push @after, $self->madness('e');
2697 return P5AST::op_cond->new(Kids => [@before, $retval, @after]);
2704 package PLXML::op_scope;
2711 push @newkids, $self->madness('o');
2713 push @newkids, $self->madness('{');
2714 push @newkids, $self->PLXML::op_lineseq::lineseq(@_);
2715 push @newkids, $self->madness('; }');
2717 my @folded = $self->madness('C');
2719 my @t = $self->madness('t');
2720 my @e = $self->madness('e');
2722 return $self->newtype->new(
2724 $self->madness('I ('),
2726 $self->madness(')'),
2727 $self->newtype->new(Kids => [@newkids]),
2732 return $self->newtype->new(
2734 $self->madness('I ('),
2736 $self->madness(')'),
2738 $self->newtype->new(Kids => [@newkids])
2742 return $self->newtype->new(Kids => [@newkids]);
2745 package PLXML::op_enteriter;
2749 my (undef,$range,$var) = @{$self->{Kids}};
2751 push @retval, $self->madness('v');
2752 if (!@retval and defined $var) {
2753 push @retval, $var->ast($self,@_);
2758 if (ref $range eq 'PLXML::op_null' and $$self{flags} =~ /STACKED/) {
2759 my (undef,$min,$max) = @{$range->{Kids}};
2760 push @retval, $min->ast($self,@_);
2762 if (exists $$range{mp}{O}) { # deeply buried .. operator
2763 PLXML::prepreproc($$range{mp}{O});
2765 $$range{mp}{'O'}{Kids}[0]{Kids}[0]{Kids}[0]{Kids}[0]->madness('o')
2768 push @retval, '..'; # XXX missing whitespace
2770 push @retval, $max->ast($self,@_);
2774 push @retval, $range->ast($self,@_);
2776 return $self->newtype->new(Kids => [@retval]);
2779 package PLXML::op_iter;
2780 package PLXML::op_enterloop;
2785 package PLXML::op_leaveloop;
2792 my $enterloop = $$self{Kids}[0];
2793 my $nextthing = $$self{Kids}[1];
2795 if ($$self{mp}{W}) {
2796 push @retval, $self->madness('L');
2797 push @newkids, $self->madness('W d');
2799 if (ref $enterloop eq 'PLXML::op_enteriter') {
2800 my ($var,@rest) = @{$enterloop->ast($self,@_)->{Kids}};
2801 push @newkids, $var if $var;
2802 push @newkids, $self->madness('q ( x = Q');
2803 push @newkids, @rest;
2806 push @newkids, $self->madness('(');
2807 push @newkids, $enterloop->ast($self,@_);
2812 if (ref $nextthing eq 'PLXML::op_null') {
2813 if ($$nextthing{mp}{'1'}) {
2814 push @newkids, $nextthing->madness('1');
2815 push @newkids, $self->madness(')');
2816 push @newkids, $$nextthing{Kids}[0]->blockast($self,@_);
2818 elsif ($$nextthing{mp}{'2'}) {
2819 push @newkids, $$nextthing{Kids}[0]->ast($self,@_);
2820 push @newkids, $self->madness(')');
2821 push @newkids, $$nextthing{mp}{'2'}->blockast($self,@_);
2823 elsif ($$nextthing{mp}{'U'}) {
2824 push @newkids, $nextthing->ast($self,@_);
2827 # bypass the op_null
2828 $andor = $nextthing->{Kids}[0];
2830 push @newkids, $$andor{Kids}[0]->ast($self, @_);
2832 push @newkids, $self->madness(')');
2834 push @newkids, $$andor{Kids}[1]->blockast($self, @_);
2839 $andor = $nextthing;
2840 push @newkids, $nextthing->madness('O');
2841 push @newkids, $self->madness(')');
2842 push @newkids, $nextthing->blockast($self, @_);
2844 if ($$self{mp}{w}) {
2845 push @newkids, $self->madness('w');
2846 push @newkids, $enterloop->ast($self,@_);
2849 push @retval, @newkids;
2851 return $self->newtype->new(Kids => [@retval]);
2854 package PLXML::op_return;
2855 package PLXML::op_last;
2856 package PLXML::op_next;
2857 package PLXML::op_redo;
2858 package PLXML::op_dump;
2859 package PLXML::op_goto;
2860 package PLXML::op_exit;
2861 package PLXML::op_open;
2862 package PLXML::op_close;
2863 package PLXML::op_pipe_op;
2864 package PLXML::op_fileno;
2865 package PLXML::op_umask;
2866 package PLXML::op_binmode;
2867 package PLXML::op_tie;
2868 package PLXML::op_untie;
2869 package PLXML::op_tied;
2870 package PLXML::op_dbmopen;
2871 package PLXML::op_dbmclose;
2872 package PLXML::op_sselect;
2873 package PLXML::op_select;
2874 package PLXML::op_getc;
2875 package PLXML::op_read;
2876 package PLXML::op_enterwrite;
2877 package PLXML::op_leavewrite;
2878 package PLXML::op_prtf;
2879 package PLXML::op_print;
2880 package PLXML::op_sysopen;
2881 package PLXML::op_sysseek;
2882 package PLXML::op_sysread;
2883 package PLXML::op_syswrite;
2884 package PLXML::op_send;
2885 package PLXML::op_recv;
2886 package PLXML::op_eof;
2887 package PLXML::op_tell;
2888 package PLXML::op_seek;
2889 package PLXML::op_truncate;
2890 package PLXML::op_fcntl;
2891 package PLXML::op_ioctl;
2892 package PLXML::op_flock;
2893 package PLXML::op_socket;
2894 package PLXML::op_sockpair;
2895 package PLXML::op_bind;
2896 package PLXML::op_connect;
2897 package PLXML::op_listen;
2898 package PLXML::op_accept;
2899 package PLXML::op_shutdown;
2900 package PLXML::op_gsockopt;
2901 package PLXML::op_ssockopt;
2902 package PLXML::op_getsockname;
2903 package PLXML::op_getpeername;
2904 package PLXML::op_lstat;
2905 package PLXML::op_stat;
2906 package PLXML::op_ftrread;
2907 package PLXML::op_ftrwrite;
2908 package PLXML::op_ftrexec;
2909 package PLXML::op_fteread;
2910 package PLXML::op_ftewrite;
2911 package PLXML::op_fteexec;
2912 package PLXML::op_ftis;
2913 package PLXML::op_fteowned;
2914 package PLXML::op_ftrowned;
2915 package PLXML::op_ftzero;
2916 package PLXML::op_ftsize;
2917 package PLXML::op_ftmtime;
2918 package PLXML::op_ftatime;
2919 package PLXML::op_ftctime;
2920 package PLXML::op_ftsock;
2921 package PLXML::op_ftchr;
2922 package PLXML::op_ftblk;
2923 package PLXML::op_ftfile;
2924 package PLXML::op_ftdir;
2925 package PLXML::op_ftpipe;
2926 package PLXML::op_ftlink;
2927 package PLXML::op_ftsuid;
2928 package PLXML::op_ftsgid;
2929 package PLXML::op_ftsvtx;
2930 package PLXML::op_fttty;
2931 package PLXML::op_fttext;
2932 package PLXML::op_ftbinary;
2933 package PLXML::op_chdir;
2934 package PLXML::op_chown;
2935 package PLXML::op_chroot;
2936 package PLXML::op_unlink;
2937 package PLXML::op_chmod;
2938 package PLXML::op_utime;
2939 package PLXML::op_rename;
2940 package PLXML::op_link;
2941 package PLXML::op_symlink;
2942 package PLXML::op_readlink;
2943 package PLXML::op_mkdir;
2944 package PLXML::op_rmdir;
2945 package PLXML::op_open_dir;
2946 package PLXML::op_readdir;
2947 package PLXML::op_telldir;
2948 package PLXML::op_seekdir;
2949 package PLXML::op_rewinddir;
2950 package PLXML::op_closedir;
2951 package PLXML::op_fork;
2952 package PLXML::op_wait;
2953 package PLXML::op_waitpid;
2954 package PLXML::op_system;
2955 package PLXML::op_exec;
2956 package PLXML::op_kill;
2957 package PLXML::op_getppid;
2958 package PLXML::op_getpgrp;
2959 package PLXML::op_setpgrp;
2960 package PLXML::op_getpriority;
2961 package PLXML::op_setpriority;
2962 package PLXML::op_time;
2963 package PLXML::op_tms;
2964 package PLXML::op_localtime;
2965 package PLXML::op_gmtime;
2966 package PLXML::op_alarm;
2967 package PLXML::op_sleep;
2968 package PLXML::op_shmget;
2969 package PLXML::op_shmctl;
2970 package PLXML::op_shmread;
2971 package PLXML::op_shmwrite;
2972 package PLXML::op_msgget;
2973 package PLXML::op_msgctl;
2974 package PLXML::op_msgsnd;
2975 package PLXML::op_msgrcv;
2976 package PLXML::op_semget;
2977 package PLXML::op_semctl;
2978 package PLXML::op_semop;
2979 package PLXML::op_require;
2980 package PLXML::op_dofile;
2981 package PLXML::op_entereval;
2985 local $::curstate; # eval {} has own statement sequence
2986 return $self->SUPER::ast(@_);
2989 package PLXML::op_leaveeval;
2990 package PLXML::op_entertry;
2991 package PLXML::op_leavetry;
2996 return $self->PLXML::op_leave::ast(@_);
2999 package PLXML::op_ghbyname;
3000 package PLXML::op_ghbyaddr;
3001 package PLXML::op_ghostent;
3002 package PLXML::op_gnbyname;
3003 package PLXML::op_gnbyaddr;
3004 package PLXML::op_gnetent;
3005 package PLXML::op_gpbyname;
3006 package PLXML::op_gpbynumber;
3007 package PLXML::op_gprotoent;
3008 package PLXML::op_gsbyname;
3009 package PLXML::op_gsbyport;
3010 package PLXML::op_gservent;
3011 package PLXML::op_shostent;
3012 package PLXML::op_snetent;
3013 package PLXML::op_sprotoent;
3014 package PLXML::op_sservent;
3015 package PLXML::op_ehostent;
3016 package PLXML::op_enetent;
3017 package PLXML::op_eprotoent;
3018 package PLXML::op_eservent;
3019 package PLXML::op_gpwnam;
3020 package PLXML::op_gpwuid;
3021 package PLXML::op_gpwent;
3022 package PLXML::op_spwent;
3023 package PLXML::op_epwent;
3024 package PLXML::op_ggrnam;
3025 package PLXML::op_ggrgid;
3026 package PLXML::op_ggrent;
3027 package PLXML::op_sgrent;
3028 package PLXML::op_egrent;
3029 package PLXML::op_getlogin;
3030 package PLXML::op_syscall;
3031 package PLXML::op_lock;
3032 package PLXML::op_threadsv;
3033 package PLXML::op_setstate;
3034 package PLXML::op_method_named;
3038 return $self->madness('O');
3041 package PLXML::op_dor;
3045 $self->PLXML::op_or::astnull(@_);
3048 package PLXML::op_dorassign;
3049 package PLXML::op_custom;