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
23 my $filename = $options{'input'} or die;
24 $deinterpolate = $options{'deinterpolate'};
25 my $YAML = $options{'YAML'};
27 local $SIG{__DIE__} = sub {
29 $e =~ s/\n$/\n [NODE $filename line $::prevstate->{line}]/ if $::prevstate;
35 my $p1 = XML::Parser->new(Style => 'Objects', Pkg => 'PLXML');
36 $p1->setHandlers('Char' => sub { warn "Chars $_[1]" if $_[1] =~ /\S/; });
38 # First slurp XML into tree of objects.
40 my $root = $p1->parsefile($filename);
42 # Now turn XML tree into something more like an AST.
44 PLXML::prepreproc($root->[0]);
45 my $ast = P5AST->new('Kids' => [$root->[0]->ast()]);
50 return YAML::Syck::Dump($ast);
53 # Finally, walk AST to produce new program.
55 my $text = $ast->p5text(); # returns encoded, must output raw
61 $::curenc = 1; # start in iso-8859-1, sigh...
63 $::H = "HeredocHere000";
82 'o' => 'p5::operator',
83 '~' => 'p5::operator',
98 'a' => 'p5::operator',
99 'A' => 'p5::operator',
100 'd' => 'p5::declarator',
105 'q' => 'p5::openquote',
106 'Q' => 'p5::closequote',
110 's' => 'p5::declarator',
111 # 'V' => 'p5::version',
116 $Data::Dumper::Indent = 1;
117 $Data::Dumper::Quotekeys = 0;
120 my $text = Dumper(@_);
121 # doesn't scale well, alas
122 1 while $text =~ s/(.*)^([^\n]*)bless\( \{\n(.*?)^(\s*\}), '([^']*)' \)([^\n]*)/$1$2$5 {\n$3$4$6 # $5/ms;
123 $text =~ s/PLXML:://g;
125 my ($package, $filename, $line) = caller;
126 my $subroutine = (caller(1))[3];
127 $text =~ s/\n?\z/, called from $subroutine, line $line\n/;
147 warn xdolist($indent,"LIST",@_);
150 my $type = ref $_[0];
152 warn xdoitem($indent,$type,@_);
155 warn xdoitem($indent,"ITEM",@_);
163 my $in = ' ' x ($indent * 2);
165 $result .= "$in<$tag>\n" if defined $tag;
167 my $itt = ref $it || "ITEM";
169 $result .= xdoitem($indent+1,$itt,$it);
171 $result .= "$in</$tag>\n" if defined $tag;
179 my $in = ' ' x ($indent * 2);
180 my $result = "$in<$tag>\n";
181 my @keys = sort keys %$hash;
184 $longest = length($k) if length($k) > $longest;
189 $K = $$hash{$k}, next if $k eq 'Kids';
190 my $sp = ' ' x ($longest - length($k));
191 if (ref $$hash{$k}) {
192 $tmp = xdoitem($indent+1,"kv",$$hash{$k});
193 $tmp =~ s!^ *<kv>\n *</kv>!$in <kv/>!;
196 $tmp = xdoitem($indent+1,"kv",$$hash{$k});
198 $k =~ s/([\t\n'"<>&])/$xmlrepl{$1}/g;
199 $tmp =~ s/<kv/<kv k='$k'$sp/ or
200 $tmp =~ s/^(.*)$/$in <kv k='$k'>\n$in $1$in <\/kv>\n/s;
204 $result .= xdolist($indent, undef, @$K);
206 $result .= "$in</$tag>\n";
213 my $in = ' ' x ($indent * 2);
216 $item =~ s/([\t\n'"<>&])/$xmlrepl{$1}/g;
217 return "$in<$tag>$item</$tag>\n";
219 (my $newtag = $r) =~ s/::/:/g;
221 if ($t =~ /\bARRAY\b/) {
223 return xdolist($indent,$tag,@{$item});
226 return "$in<$tag />\n";
229 if ($t =~ /\bHASH\b/) {
230 return xdohash($indent,$tag,$item);
233 return "$in<$newtag>$$item</$newtag>\n";
236 return "$in<$newtag type='$r'/>\n";
250 tdolist($indent,"LIST",@_);
253 my $type = ref $_[0];
255 tdoitem($indent,$type,@_);
258 tdoitem($indent,"ITEM",@_);
266 my $tag = shift || "ARRAY";
267 my $in = ' ' x ($indent * 2);
271 my $itt = ref $it || "ITEM";
272 print STDERR $in," ";
273 tdoitem($indent+1,$itt,$it);
287 my $in = ' ' x ($indent * 2);
289 print STDERR "$tag => {\n";
291 my @keys = sort keys %$hash;
294 $longest = length($k) if length($k) > $longest;
298 my $sp = ' ' x ($longest - length($k));
299 print STDERR "$in $k$sp => ";
300 tdoitem($indent+1,"",$$hash{$k});
302 print STDERR " # Kids";
306 print STDERR "$in} # $tag";
313 if (not defined $item) {
314 print STDERR "UNDEF";
317 # my $in = ' ' x ($indent * 2);
320 $item =~ s/([\t\n"])/$trepl{$1}/g;
321 print STDERR "\"$item\"";
326 my $str = $$item{uni};
327 my $enc = $enc[$$item{enc}] . ' ';
328 $enc =~ s/iso-8859-1 //;
329 $str =~ s/([\t\n"])/$trepl{$1}/g;
330 print STDERR "$r $enc\"$str\"";
332 elsif ($t =~ /\bARRAY\b/) {
333 tdolist($indent,$tag,@{$item});
335 elsif ($t =~ /\bHASH\b/) {
336 tdohash($indent,$tag,$item);
339 print STDERR "$r type='$r'";
346 if (not exists $enc{$encname}) {
348 return $enc{$encname} = $#enc;
350 return $enc{$encname};
362 die "Too many args to new" if @_;
363 die "Attempt to bless non-text $text" if ref $text;
364 return bless( { uni => $text,
369 sub uni { my $self = shift; $$self{uni}; } # internal stuff all in utf8
373 my $enc = $enc[$$self{enc} || 0];
374 return encode($enc, $$self{uni});
377 package p5::closequote; BEGIN { @p5::closequote::ISA = 'p5::punct'; }
378 package p5::closer; BEGIN { @p5::closer::ISA = 'p5::punct'; }
379 package p5::declarator; BEGIN { @p5::declarator::ISA = 'p5::token'; }
380 package p5::junk; BEGIN { @p5::junk::ISA = 'p5::text'; }
381 package p5::label; BEGIN { @p5::label::ISA = 'p5::token'; }
382 #package p5::name; BEGIN { @p5::name::ISA = 'p5::token'; }
383 package p5::opener; BEGIN { @p5::opener::ISA = 'p5::punct'; }
384 package p5::openquote; BEGIN { @p5::openquote::ISA = 'p5::punct'; }
385 package p5::operator; BEGIN { @p5::operator::ISA = 'p5::token'; }
386 package p5::punct; BEGIN { @p5::punct::ISA = 'p5::token'; }
387 package p5::remod; BEGIN { @p5::remod::ISA = 'p5::token'; }
388 package p5::sigil; BEGIN { @p5::sigil::ISA = 'p5::punct'; }
389 package p5::token; BEGIN { @p5::token::ISA = 'p5::text'; }
390 #package p5::version; BEGIN { @p5::version::ISA = 'p5::token'; }
392 ################################################################
393 # Routines to turn XML tree into an AST. Mostly this amounts to hoisting
394 # misplaced nodes and flattening various things into lists.
399 ::x("AUTOLOAD $PLXML::AUTOLOAD", @_);
400 return "[[[ $PLXML::AUTOLOAD ]]]";
405 my $kids = $$self{Kids};
409 for ($i = 0; $i < @$kids; $i++) {
410 if (ref $kids->[$i] eq "PLXML::madprops") {
411 $self->{mp} = splice(@$kids, $i, 1)->hash($self,@_);
416 prepreproc($kids->[$i], $self, @_);
424 if (ref $self eq 'PLXML::op_null' and $$self{was}) {
425 return "PLXML::op_$$self{was}"->key();
434 my $t = ref $self || $self;
435 $t = "PLXML::op_$$self{was}" if $t eq 'PLXML::op_null' and $$self{was};
436 $t =~ s/PLXML/P5AST/ or die "Bad type: $t";
442 my @keys = split(' ', shift);
444 for my $key (@keys) {
445 my $madprop = $self->{mp}{$key};
446 next unless defined $madprop;
447 if (ref $madprop eq 'PLXML::mad_op') {
449 push @vals, $madprop->blockast($self, @_);
452 push @vals, $madprop->ast($self, @_);
457 if ($white = $self->{mp}{"_$key"}) {
458 push @vals, p5::junk->new($white);
460 my $type = $madtype{$key} || "p5::token";
461 push @vals, $type->new($madprop);
462 if ($white = $self->{mp}{"#$key"}) {
463 push @vals, p5::junk->new($white);
478 for my $kid (@{$$self{Kids}}) {
479 push @newkids, $kid->ast($self, @_);
481 return $self->newtype->new(Kids => [uc $self->key(), "(", @newkids, ")"]);
486 my $desc = $self->desc();
487 if ($desc =~ /\((.*?)\)/) {
491 return " <<" . $self->key() . ">> ";
500 package PLXML::Characters;
502 sub ast { die "oops" }
503 sub pair { die "oops" }
505 package PLXML::madprops;
518 # We need to guarantee key uniqueness at this point.
519 for my $kid (@{$$self{Kids}}) {
520 my ($k,$v) = $kid->pair($self, @_);
522 if ($k =~ /^[_#]$/) { # rekey whitespace according to preceding entry
523 $k .= $lastthing; # (which is actually the token the whitespace is before)
526 $k .= 'x' while exists $hash{$k};
531 $hash{FIRST} = $firstthing;
532 $hash{LAST} = $lastthing;
536 package PLXML::mad_op;
540 my $key = $$self{key};
546 $self->prepreproc(@_);
548 for my $kid (@{$$self{Kids}}) {
549 push @vals, $kid->ast($self, @_);
555 return P5AST::op_list->new(Kids => [@vals]);
561 $self->prepreproc(@_);
563 for my $kid (@{$$self{Kids}}) {
564 push @vals, $kid->blockast($self, @_);
570 return P5AST::op_lineseq->new(Kids => [@vals]);
574 package PLXML::mad_pv;
578 my $key = $$self{key};
579 my $val = $$self{val};
580 $val =~ s/STUPIDXML\(#x(\w+)\)/chr(hex $1)/eg;
584 package PLXML::mad_sv;
588 my $key = $$self{key};
589 my $val = $$self{val};
590 $val =~ s/STUPIDXML\(#x(\w+)\)/chr(hex $1)/eg;
594 package PLXML::baseop;
601 for my $kid (@{$$self{Kids}}) {
602 push @newkids, $kid->ast($self, @_);
605 push @retval, uc $self->key(), "(", @newkids , ")";
608 push @retval, $self->madness('o ( )');
610 return $self->newtype->new(Kids => [@retval]);
613 package PLXML::baseop_unop;
617 my @newkids = $self->madness('d o (');
619 if (exists $$self{Kids}) {
620 my $arg = $$self{Kids}[0];
621 push @newkids, $arg->ast($self, @_) if defined $arg;
623 push @newkids, $self->madness(')');
625 return $self->newtype()->new(Kids => [@newkids]);
628 package PLXML::binop;
634 my $left = $$self{Kids}[0];
635 push @newkids, $left->ast($self, @_);
637 push @newkids, $self->madness('o');
639 my $right = $$self{Kids}[1];
640 if (defined $right) {
641 push @newkids, $right->ast($self, @_);
644 return $self->newtype->new(Kids => [@newkids]);
649 package PLXML::filestatop;
654 my @newkids = $self->madness('o (');
656 if (@{$$self{Kids}}) {
657 for my $kid (@{$$self{Kids}}) {
658 push @newkids, $kid->ast($self, @_);
662 push @newkids, $self->madness('O');
664 push @newkids, $self->madness(')');
666 return $self->newtype->new(Kids => [@newkids]);
669 package PLXML::listop;
676 if (@retval = $self->madness('X')) {
677 my @before, $self->madness('o x');
678 return P5AST::listop->new(Kids => [@before,@retval]);
681 push @retval, $self->madness('o ( [ {');
684 for my $kid (@{$$self{Kids}}) {
685 next if ref $kid eq 'PLXML::op_pushmark';
686 next if ref $kid eq 'PLXML::op_null' and
687 defined $$kid{was} and $$kid{was} eq 'pushmark';
688 push @newkids, $kid->ast($self, @_);
694 push @retval, $self->madness('S');
696 push @retval, @newkids;
698 push @retval, $self->madness('} ] )');
699 return $self->newtype->new(Kids => [@retval,@after]);
702 package PLXML::logop;
708 push @newkids, $self->madness('o (');
709 for my $kid (@{$$self{Kids}}) {
710 push @newkids, $kid->ast($self, @_);
712 push @newkids, $self->madness(')');
713 return $self->newtype->new(Kids => [@newkids]);
718 package PLXML::loopexop;
722 my @newkids = $self->madness('o (');
724 if ($$self{mp}{L} or not $$self{flags} =~ /\bSPECIAL\b/) {
725 my @label = $self->madness('L');
727 push @newkids, @label;
730 my $arg = $$self{Kids}[0];
731 push @newkids, $arg->ast($self, @_) if defined $arg;
734 push @newkids, $self->madness(')');
736 return $self->newtype->new(Kids => [@newkids]);
740 package PLXML::padop;
742 package PLXML::padop_svop;
749 return P5AST::pmop->new(Kids => []) unless exists $$self{flags};
751 my $bits = $self->fetchbits($$self{flags},@_);
754 if ($bits->{binding}) {
755 push @newkids, $bits->{binding};
756 push @newkids, $self->madness('~');
758 if (exists $bits->{regcomp} and $bits->{regcomp}) {
759 my @front = $self->madness('q');
760 my @back = $self->madness('Q');
761 push @newkids, @front, $bits->{regcomp}, @back,
764 elsif ($$self{mp}{q}) {
765 push @newkids, $self->madness('q = Q m');
767 elsif ($$self{mp}{X}) {
768 push @newkids, $self->madness('X m');
771 push @newkids, $self->madness('e m');
774 return $self->newtype->new(Kids => [@newkids]);
780 for my $key (grep {!/^Kids/} keys %$pmop) {
781 $bits->{$key} = $pmop->{$key};
784 # Have to delete all the fake evals of the repl. This is a pain...
785 if (@{$$pmop{Kids}}) {
786 my $really = $$pmop{Kids}[0]{Kids}[0];
787 if (ref $really eq 'PLXML::op_substcont') {
788 $really = $$really{Kids}[0];
790 while ((ref $really) =~ /^PLXML::op_.*(null|entereval)/) {
791 if (exists $$really{was}) {
792 $bits->{repl} = $really->ast(@_);
795 $really = $$really{Kids}[0];
797 if (ref $really eq 'PLXML::op_scope' and
798 @{$$really{Kids}} == 1 and
799 ref $$really{Kids}[0] eq 'PLXML::op_null' and
800 not @{$$really{Kids}[0]{Kids}})
805 if (ref $really eq 'PLXML::op_leave' and
806 @{$$really{Kids}} == 2 and
807 ref $$really{Kids}[1] eq 'PLXML::op_null' and
808 not @{$$really{Kids}[1]{Kids}})
813 if ((ref $really) =~ /^PLXML::op_(scope|leave)/) {
814 # should be at inner do {...} here, so skip that fakery too
815 $bits->{repl} = $really->newtype->new(Kids => [$really->PLXML::op_lineseq::lineseq(@_)]);
816 # but retrieve the whitespace before fake '}'
817 if ($$really{mp}{'_}'}) {
818 push(@{$bits->{repl}->{Kids}}, p5::junk->new($$really{mp}{'_}'}));
821 else { # something else, padsv probably
822 $bits->{repl} = $really->ast(@_);
829 my $flags = shift || '';
831 my @kids = @{$$self{Kids}};
834 my $arg = shift @kids;
835 innerpmop($arg,\%bits, $self, @_);
836 if ($flags =~ /STACKED/) {
838 $bits{binding} = $arg->ast($self, @_);
840 if ($bits{when} ne "COMP" and @kids) {
842 $bits{regcomp} = $arg->ast($self, @_);
844 if (not exists $bits{repl} and @kids) {
846 $bits{repl} = $arg->ast($self, @_);
852 package PLXML::pvop_svop;
858 my @newkids = $self->madness('o (');
860 if (exists $$self{Kids}) {
861 my $arg = $$self{Kids}[0];
862 push @newkids, $arg->ast($self, @_) if defined $arg;
864 push @newkids, $self->madness(')');
866 return $self->newtype->new(Kids => [@newkids]);
870 package PLXML::Characters;
871 package PLXML::madprops;
872 package PLXML::mad_op;
873 package PLXML::mad_pv;
874 package PLXML::baseop;
875 package PLXML::baseop_unop;
876 package PLXML::binop;
878 package PLXML::filestatop;
879 package PLXML::listop;
880 package PLXML::logop;
882 package PLXML::loopexop;
883 package PLXML::padop;
884 package PLXML::padop_svop;
886 package PLXML::pvop_svop;
888 package PLXML::op_null;
890 # Null nodes typed by first madprop.
896 'p' => sub { # peg for #! line, etc.
899 push @newkids, $self->madness('p px');
901 return P5AST::peg->new(Kids => [@newkids])
903 '(' => sub { # extra parens around the whole thing
906 push @newkids, $self->madness('dx d o (');
907 for my $kid (@{$$self{Kids}}) {
908 push @newkids, $kid->ast($self, @_);
910 push @newkids, $self->madness(')');
911 return P5AST::parens->new(Kids => [@newkids])
913 '~' => sub { # binding operator
916 push @newkids, $$self{Kids}[0]->ast($self,@_);
917 push @newkids, $self->madness('~');
918 push @newkids, $$self{Kids}[1]->ast($self,@_);
919 return P5AST::bindop->new(Kids => [@newkids])
921 ';' => sub { # null statements/blocks
924 push @newkids, $self->madness('{ ; }');
926 return P5AST::nothing->new(Kids => [@newkids])
928 'I' => sub { # if or unless statement keyword
931 push @newkids, $self->madness('L I (');
933 for my $kid (@{$$self{Kids}}) {
934 push @subkids, $kid->ast($self, @_);
936 die "oops in op_null->new" unless @subkids == 1;
937 my $newself = $subkids[0];
938 @subkids = @{$$newself{Kids}};
940 unshift @{$subkids[0]{Kids}}, @newkids;
941 push @{$subkids[0]{Kids}}, $self->madness(')');
942 return bless($newself, 'P5AST::condstate');
947 my @module = $self->madness('U');
948 my @args = $self->madness('A');
949 my $module = $module[-1]{Kids}[-1];
950 if ($module->uni eq 'bytes') {
951 $::curenc = Nomad::encnum('iso-8859-1');
953 elsif ($module->uni eq 'utf8') {
954 if ($$self{mp}{o} eq 'no') {
955 $::curenc = Nomad::encnum('iso-8859-1');
958 $::curenc = Nomad::encnum('utf-8');
961 elsif ($module->uni eq 'encoding') {
962 if ($$self{mp}{o} eq 'no') {
963 $::curenc = Nomad::encnum('iso-8859-1');
966 $::curenc = Nomad::encnum(eval $args[0]->p5text); # XXX bletch
969 # (Surrounding {} ends up here if use is only thing in block.)
970 push @newkids, $self->madness('{ o');
971 push @newkids, @module;
972 push @newkids, $self->madness('V');
973 push @newkids, @args;
974 push @newkids, $self->madness('S ; }');
976 return P5AST::use->new(Kids => [@newkids])
978 '?' => sub { # ternary
982 my @condkids = @{$$self{Kids}[0]{Kids}};
984 push @newkids, $condkids[0]->ast($self,@_), $self->madness('?');
985 push @newkids, $condkids[1]->ast($self,@_), $self->madness(':');
986 push @newkids, $condkids[2]->ast($self,@_);
987 return P5AST::ternary->new(Kids => [@newkids])
989 '&' => sub { # subroutine
992 push @newkids, $self->madness('d n s a : { & } ;');
994 return P5AST::sub->new(Kids => [@newkids])
996 'i' => sub { # modifier if
999 push @newkids, $self->madness('i');
1000 my $cond = $$self{Kids}[0];
1002 for my $kid (@{$$cond{Kids}}) {
1003 push @subkids, $kid->ast($self, @_);
1005 push @newkids, shift @subkids;
1006 unshift @newkids, @subkids;
1007 return P5AST::condmod->new(Kids => [@newkids])
1009 'P' => sub { # package declaration
1012 push @newkids, $self->madness('o');
1013 push @newkids, $self->madness('P');
1014 push @newkids, $self->madness(';');
1016 return P5AST::package->new(Kids => [@newkids])
1018 'F' => sub { # format
1020 my @newkids = $self->madness('F n b');
1022 return P5AST::format->new(Kids => [@newkids])
1024 'x' => sub { # qw literal
1026 return P5AST::qwliteral->new(Kids => [$self->madness('x')])
1028 'q' => sub { # random quote
1030 return P5AST::quote->new(Kids => [$self->madness('q = Q')])
1032 'X' => sub { # random literal
1034 return P5AST::token->new(Kids => [$self->madness('X')])
1036 ':' => sub { # attr list
1038 return P5AST::attrlist->new(Kids => [$self->madness(':')])
1040 ',' => sub { # "unary ," so to speak
1043 push @newkids, $self->madness(',');
1044 push @newkids, $$self{Kids}[0]->ast($self,@_);
1045 return P5AST::listelem->new(Kids => [@newkids])
1047 'C' => sub { # constant conditional
1050 push @newkids, $$self{Kids}[0]->ast($self,@_);
1051 my @folded = $self->madness('C');
1053 my @t = $self->madness('t');
1054 my @e = $self->madness('e');
1056 return P5AST::op_cond_expr->new(
1058 $self->madness('I ('),
1060 $self->madness(') ?'),
1061 P5AST::op_cond_expr->new(Kids => [@newkids]),
1062 $self->madness(':'),
1067 return P5AST::op_cond_expr->new(
1069 $self->madness('I ('),
1071 $self->madness(') ?'),
1073 $self->madness(':'),
1078 return P5AST::op_null->new(Kids => [@newkids])
1080 '+' => sub { # unary +
1083 push @newkids, $self->madness('+');
1084 push @newkids, $$self{Kids}[0]->ast($self,@_);
1085 return P5AST::preplus->new(Kids => [@newkids])
1087 'D' => sub { # do block
1090 push @newkids, $self->madness('D');
1091 push @newkids, $$self{Kids}[0]->ast($self,@_);
1092 return P5AST::doblock->new(Kids => [@newkids])
1094 '3' => sub { # C-style for loop
1099 my (undef, $init, $lineseq) = @{$$self{Kids}[0]{Kids}};
1100 my (undef, $leaveloop) = @{$$lineseq{Kids}};
1101 my (undef, $null) = @{$$leaveloop{Kids}};
1107 if (exists $$null{was} and $$null{was} eq 'and') {
1108 ($lineseq2) = @{$$null{Kids}};
1111 ($and) = @{$$null{Kids}};
1112 ($cond, $lineseq2) = @{$$and{Kids}};
1114 if ($$lineseq2{mp}{'{'}) {
1118 ($block, $cont) = @{$$lineseq2{Kids}};
1121 push @newkids, $self->madness('L 3 (');
1122 push @newkids, $init->ast($self,@_);
1123 push @newkids, $self->madness('1');
1124 if (defined $cond) {
1125 push @newkids, $cond->ast($self,@_);
1127 elsif (defined $null) {
1128 push @newkids, $null->madness('1');
1130 push @newkids, $self->madness('2');
1131 if (defined $cont) {
1132 push @newkids, $cont->ast($self,@_);
1134 push @newkids, $self->madness(')');
1135 push @newkids, $block->blockast($self,@_);
1137 return P5AST::cfor->new(Kids => [@newkids])
1139 'o' => sub { # random useless operator
1142 push @newkids, $self->madness('o');
1143 my $kind = $newkids[-1] || '';
1144 $kind = $kind->uni if ref $kind;
1146 for my $kid (@{$$self{Kids}}) {
1147 push @subkids, $kid->ast($self, @_);
1149 if ($kind eq '=') { # stealth readline
1150 unshift(@newkids, shift(@subkids));
1151 push(@newkids, @subkids);
1152 return P5AST::op_aassign->new(Kids => [@newkids])
1155 my $newself = $subkids[0];
1156 splice(@{$newself->{Kids}}, 1, 0,
1157 $self->madness('ox ('),
1167 # Null nodes are an untyped mess inside Perl. Instead of fixing it there,
1168 # we derive an effective type either from the "was" field or the first madprop.
1169 # (The individual routines select the actual new type.)
1173 my $was = $$self{was} || 'peg';
1174 my $mad = $$self{mp}{FIRST} || "unknown";
1176 # First try for a "was".
1177 my $meth = "PLXML::op_${was}::astnull";
1178 if (exists &{$meth}) {
1179 return $self->$meth(@_);
1182 # Look at first madprop.
1183 if (exists $astmad{$mad}) {
1184 return $astmad{$mad}->($self);
1186 warn "No mad $mad" unless $mad eq 'unknown';
1188 # Do something generic.
1190 for my $kid (@{$$self{Kids}}) {
1191 push @newkids, $kid->ast($self, @_);
1193 return $self->newtype->new(Kids => [@newkids]);
1199 local $::curenc = $::curenc;
1200 return $self->madness('{ ; }');
1203 package PLXML::op_stub;
1207 return $self->newtype->new(Kids => [$self->madness(', x ( ) q = Q')]);
1210 package PLXML::op_scalar;
1215 my @pre = $self->madness('o q');
1217 if ($op->uni =~ /^<</) {
1219 my $opstub = bless { start => $op }, 'P5AST::heredoc';
1220 push @newkids, $opstub;
1221 push @newkids, $self->madness('(');
1223 my @kids = @{$$self{Kids}};
1226 for my $kid (@kids) {
1227 next if ref $kid eq 'PLXML::op_pushmark';
1228 next if ref $kid eq 'PLXML::op_null' and
1229 defined $$kid{was} and $$kid{was} eq 'pushmark';
1230 push @divert, $kid->ast($self, @_);
1232 $opstub->{doc} = P5AST::op_list->new(Kids => [@divert]);
1233 $opstub->{end} = ($self->madness('Q'))[-1];
1235 push @newkids, $self->madness(')');
1237 return $self->newtype->new(Kids => [@pre,@newkids]);
1239 return $self->PLXML::baseop_unop::ast();
1242 package PLXML::op_pushmark;
1246 package PLXML::op_wantarray;
1247 package PLXML::op_const;
1252 return unless $$self{mp};
1253 push @newkids, $self->madness('q = Q X : f O ( )');
1254 return P5AST::op_const->new(Kids => [@newkids]);
1259 return unless %{$$self{mp}};
1264 my @args = $self->madness('f');
1267 elsif (exists $self->{mp}{q}) {
1268 push @args, $self->madness('d q');
1269 if ($args[-1]->uni =~ /^<</) {
1270 my $opstub = bless { start => pop(@args) }, 'P5AST::heredoc';
1271 $opstub->{doc} = P5AST::op_const->new(Kids => [$self->madness('=')]);
1272 $opstub->{end} = ($self->madness('Q'))[-1];
1273 push @args, $opstub;
1276 push @args, $self->madness('= Q');
1279 elsif (exists $self->{mp}{X}) {
1280 push @before, $self->madness('d'); # was local $[ probably
1281 if (not $$self{mp}{O}) {
1282 push @before, $self->madness('o'); # was unary
1284 my @X = $self->madness(': X');
1285 if (exists $$self{private} and $$self{private} =~ /BARE/) {
1286 return $self->newtype->new(Kids => [@X]);
1291 $self->madness('x'),
1293 if ($$self{mp}{O}) {
1294 push @args, $self->madness('o O');
1297 elsif (exists $self->{mp}{O}) {
1298 push @args, $self->madness('O');
1300 elsif ($$self{private} =~ /\bBARE\b/) {
1301 @args = ($$self{PV});
1303 elsif (exists $$self{mp}{o}) {
1304 @args = $self->madness('o');
1306 elsif (exists $$self{PV}) {
1307 @args = ('"', $$self{PV}, '"');
1309 elsif (exists $$self{NV}) {
1312 elsif (exists $$self{IV}) {
1316 @args = $self->SUPER::text(@_);
1318 return $self->newtype->new(Kids => [@before, @args]);
1322 package PLXML::op_gvsv;
1328 for my $attr (qw/gv GV flags/) {
1329 if (exists $$self{$attr}) {
1330 push @args, $attr, $$self{$attr};
1333 push @retval, @args;
1334 push @retval, $self->madness('X');
1335 return $self->newtype->new(Kids => [@retval]);
1338 package PLXML::op_gv;
1343 push @newkids, $self->madness('X K');
1345 return $self->newtype->new(Kids => [@newkids]);
1348 package PLXML::op_gelem;
1353 local $::curstate; # in case there are statements in subscript
1354 local $::curenc = $::curenc;
1356 push @newkids, $self->madness('dx d');
1357 for my $kid (@{$$self{Kids}}) {
1358 push @newkids, $kid->ast($self, @_);
1360 splice @newkids, -1, 0, $self->madness('o {');
1361 push @newkids, $self->madness('}');
1363 return $self->newtype->new(Kids => [@newkids]);
1366 package PLXML::op_padsv;
1371 push @args, $self->madness('dx d ( $ )');
1373 return $self->newtype->new(Kids => [@args]);
1376 package PLXML::op_padav;
1378 sub astnull { ast(@_) }
1383 push @retval, $self->madness('dx d (');
1384 push @retval, $self->madness('$ @');
1385 push @retval, $self->madness(') o O');
1386 return $self->newtype->new(Kids => [@retval]);
1389 package PLXML::op_padhv;
1391 sub astnull { ast(@_) }
1396 push @retval, $self->madness('dx d (');
1397 push @retval, $self->madness('$ @ %');
1398 push @retval, $self->madness(') o O');
1399 return $self->newtype->new(Kids => [@retval]);
1402 package PLXML::op_padany;
1404 package PLXML::op_pushre;
1408 if ($$self{mp}{q}) {
1409 return $self->madness('q = Q m');
1411 if ($$self{mp}{X}) {
1412 return $self->madness('X m');
1414 if ($$self{mp}{e}) {
1415 return $self->madness('e m');
1417 return $$self{Kids}[1]->ast($self,@_), $self->madness('m');
1420 package PLXML::op_rv2gv;
1426 push @newkids, $self->madness('dx d ( * $');
1427 push @newkids, $$self{Kids}[0]->ast();
1428 push @newkids, $self->madness(')');
1429 return $self->newtype->new(Kids => [@newkids]);
1432 package PLXML::op_rv2sv;
1436 return P5AST::op_rv2sv->new(Kids => [$self->madness('O o dx d ( $ ) : a')]);
1443 push @newkids, $self->madness('dx d ( $');
1444 if (ref $$self{Kids}[0] ne "PLXML::op_gv") {
1445 push @newkids, $$self{Kids}[0]->ast();
1447 push @newkids, $self->madness(') : a');
1448 return $self->newtype->new(Kids => [@newkids]);
1451 package PLXML::op_av2arylen;
1457 push @newkids, $$self{Kids}[0]->madness('l');
1458 push @newkids, $$self{Kids}[0]->ast();
1459 return $self->newtype->new(Kids => [@newkids]);
1462 package PLXML::op_rv2cv;
1467 push @newkids, $self->madness('X');
1468 return @newkids if @newkids;
1469 if (exists $$self{mp}{'&'}) {
1470 push @newkids, $self->madness('&');
1471 if (@{$$self{Kids}}) {
1472 push @newkids, $$self{Kids}[0]->ast(@_);
1476 push @newkids, $$self{Kids}[0]->ast(@_);
1478 return P5AST::op_rv2cv->new(Kids => [@newkids]);
1485 push @newkids, $self->madness('&');
1486 if (@{$$self{Kids}}) {
1487 push @newkids, $$self{Kids}[0]->ast();
1489 return $self->newtype->new(Kids => [@newkids]);
1492 package PLXML::op_anoncode;
1496 my $arg = $$self{Kids}[0];
1497 local $::curstate; # hide nested statements in sub
1498 local $::curenc = $::curenc;
1500 return $arg->ast(@_);
1502 return ';'; # XXX literal ; should come through somewhere
1505 package PLXML::op_prototype;
1506 package PLXML::op_refgen;
1510 my @newkids = $self->madness('o s a');
1512 if (exists $$self{Kids}) {
1513 my $arg = $$self{Kids}[0];
1514 push @newkids, $arg->ast($self, @_) if defined $arg;
1517 my $res = $self->newtype->new(Kids => [@newkids]);
1521 package PLXML::op_srefgen;
1526 if ($$self{mp}{FIRST} eq '{') {
1527 local $::curstate; # this is officially a block, so hide it
1528 local $::curenc = $::curenc;
1529 push @newkids, $self->madness('{');
1530 for my $kid (@{$$self{Kids}}) {
1531 push @newkids, $kid->ast($self, @_);
1533 push @newkids, $self->madness('; }');
1534 return P5AST::op_stringify->new(Kids => [@newkids]);
1537 push @newkids, $self->madness('o [');
1538 for my $kid (@{$$self{Kids}}) {
1539 push @newkids, $kid->ast($self, @_);
1541 push @newkids, $self->madness(']');
1542 return P5AST::op_stringify->new(Kids => [@newkids]);
1546 package PLXML::op_ref;
1547 package PLXML::op_bless;
1548 package PLXML::op_backtick;
1553 if (exists $self->{mp}{q}) {
1554 push @args, $self->madness('q');
1555 if ($args[-1]->uni =~ /^<</) {
1556 my $opstub = bless { start => $args[-1] }, 'P5AST::heredoc';
1557 $args[-1] = $opstub;
1558 $opstub->{doc} = P5AST::op_const->new(Kids => [$self->madness('=')]);
1559 $opstub->{end} = ($self->madness('Q'))[-1];
1562 push @args, $self->madness('= Q');
1565 return $self->newtype->new(Kids => [@args]);
1568 package PLXML::op_glob;
1572 my @retval = $self->madness('o q = Q');
1573 if (not @retval or $retval[-1]->uni eq 'glob') {
1574 push @retval, $self->madness('(');
1575 push @retval, $$self{Kids}[0]->ast($self,@_);
1576 push @retval, $self->madness(')');
1578 return P5AST::op_glob->new(Kids => [@retval]);
1581 package PLXML::op_readline;
1586 if (exists $$self{mp}{q}) {
1587 @retval = $self->madness('q = Q');
1589 elsif (exists $$self{mp}{X}) {
1590 @retval = $self->madness('X');
1592 return P5AST::op_readline->new(Kids => [@retval]);
1602 if (exists $$self{mp}{q}) {
1603 @args = $self->madness('q = Q');
1605 elsif (exists $$self{mp}{X}) {
1606 @args = $self->madness('X');
1608 elsif (exists $$self{GV}) {
1611 elsif (@{$$self{Kids}}) {
1612 @args = $self->PLXML::unop::ast(@_);
1615 @args = $self->SUPER::text(@_);
1617 return $self->newtype->new(Kids => [@retval,@args]);
1621 package PLXML::op_rcatline;
1622 package PLXML::op_regcmaybe;
1623 package PLXML::op_regcreset;
1624 package PLXML::op_regcomp;
1628 $self->PLXML::unop::ast(@_);
1631 package PLXML::op_match;
1635 my $retval = $self->SUPER::ast(@_);
1637 if (not $p5re = $retval->p5text()) {
1638 $retval = $self->newtype->new(Kids => [$self->madness('X q = Q m')]);
1639 $p5re = $retval->p5text();
1641 if ($deinterpolate) {
1642 $retval->{P5re} = P5re::qrparse($p5re);
1647 package PLXML::op_qr;
1652 if (exists $$self{flags}) {
1653 $retval = $self->SUPER::ast(@_);
1656 $retval = $self->newtype->new(Kids => [$self->madness('X q = Q m')]);
1658 if ($deinterpolate) {
1659 my $p5re = $retval->p5text();
1660 $retval->{P5re} = P5re::qrparse($p5re);
1665 package PLXML::op_subst;
1670 my $bits = $self->fetchbits($$self{flags},@_);
1673 if ($bits->{binding}) {
1674 push @newkids, $bits->{binding};
1675 push @newkids, $self->madness('~');
1677 my $X = p5::token->new($$self{mp}{X});
1678 my @lfirst = $self->madness('q');
1679 my @llast = $self->madness('Q');
1682 $self->madness('E'), # XXX s/b e probably
1684 my @rfirst = $self->madness('z');
1685 my @rlast = $self->madness('Z');
1686 my @mods = $self->madness('m');
1687 if ($rfirst[-1]->uni ne $llast[-1]->uni) {
1688 push @newkids, @rfirst;
1691 push @newkids, $bits->{repl}, @rlast, @mods;
1693 my $retval = $self->newtype->new(Kids => [@newkids]);
1694 if ($deinterpolate) {
1695 my $p5re = $retval->p5text();
1696 $retval->{P5re} = P5re::qrparse($p5re);
1701 package PLXML::op_substcont;
1702 package PLXML::op_trans;
1707 # my $bits = $self->fetchbits($$self{flags},@_);
1710 my @lfirst = $self->madness('q');
1711 my @llast = $self->madness('Q');
1714 $self->madness('E'),
1716 my @rfirst = $self->madness('z');
1717 my @repl = $self->madness('R');
1718 my @rlast = $self->madness('Z');
1719 my @mods = $self->madness('m');
1720 if ($rfirst[-1]->uni ne $llast[-1]->uni) {
1721 push @newkids, @rfirst;
1724 push @newkids, @repl, @rlast, @mods;
1726 my $res = $self->newtype->new(Kids => [@newkids]);
1730 package PLXML::op_sassign;
1736 my $right = $$self{Kids}[1];
1737 eval { push @newkids, $right->ast($self, @_); };
1739 push @newkids, $self->madness('o');
1741 my $left = $$self{Kids}[0];
1742 push @newkids, $left->ast($self, @_);
1744 return $self->newtype->new(Kids => [@newkids]);
1747 package PLXML::op_aassign;
1749 sub astnull { ast(@_) }
1755 my $right = $$self{Kids}[1];
1756 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_chop;
1767 package PLXML::op_schop;
1768 package PLXML::op_chomp;
1769 package PLXML::op_schomp;
1770 package PLXML::op_defined;
1771 package PLXML::op_undef;
1772 package PLXML::op_study;
1773 package PLXML::op_pos;
1774 package PLXML::op_preinc;
1778 if ($$self{targ}) { # stealth post inc or dec
1779 return $self->PLXML::op_postinc::ast(@_);
1781 return $self->SUPER::ast(@_);
1784 package PLXML::op_i_preinc;
1786 sub ast { my $self = shift; $self->PLXML::op_preinc::ast(@_); }
1788 package PLXML::op_predec;
1790 sub ast { my $self = shift; $self->PLXML::op_preinc::ast(@_); }
1792 package PLXML::op_i_predec;
1794 sub ast { my $self = shift; $self->PLXML::op_preinc::ast(@_); }
1796 package PLXML::op_postinc;
1802 if (exists $$self{Kids}) {
1803 my $arg = $$self{Kids}[0];
1804 push @newkids, $arg->ast($self, @_) if defined $arg;
1806 push @newkids, $self->madness('o');
1808 my $res = $self->newtype->new(Kids => [@newkids]);
1812 package PLXML::op_i_postinc;
1814 sub ast { my $self = shift; $self->PLXML::op_postinc::ast(@_); }
1816 package PLXML::op_postdec;
1818 sub ast { my $self = shift; $self->PLXML::op_postinc::ast(@_); }
1820 package PLXML::op_i_postdec;
1822 sub ast { my $self = shift; $self->PLXML::op_postinc::ast(@_); }
1824 package PLXML::op_pow;
1825 package PLXML::op_multiply;
1826 package PLXML::op_i_multiply;
1827 package PLXML::op_divide;
1828 package PLXML::op_i_divide;
1829 package PLXML::op_modulo;
1830 package PLXML::op_i_modulo;
1831 package PLXML::op_repeat;
1835 return $self->SUPER::ast(@_)
1836 unless exists $$self{private} and $$self{private} =~ /DOLIST/;
1838 my $newself = $$self{Kids}[0]->ast($self,@_);
1839 splice @{$newself->{Kids}}, -1, 0, $self->madness('o');
1841 return bless $newself, $self->newtype; # rebless the op_null
1844 package PLXML::op_add;
1845 package PLXML::op_i_add;
1846 package PLXML::op_subtract;
1847 package PLXML::op_i_subtract;
1848 package PLXML::op_concat;
1855 my $left = $$self{Kids}[0];
1856 push @newkids, $left->ast($self, @_);
1858 push @newkids, $self->madness('o');
1860 my $right = $$self{Kids}[1];
1861 push @newkids, $right->ast($self, @_);
1862 return P5AST::op_concat->new(Kids => [@newkids]);
1871 my $left = $$self{Kids}[0];
1872 push @newkids, $left->ast($self, @_);
1874 push @newkids, $self->madness('o');
1876 my $right = $$self{Kids}[1];
1877 push @newkids, $right->ast($self, @_);
1879 return $self->newtype->new(Kids => [@newkids, @after]);
1882 package PLXML::op_stringify;
1891 my @front = $self->madness('q (');
1892 my @back = $self->madness(') Q');
1893 my @M = $self->madness('M');
1895 push @newkids, $M[0], $self->madness('o');
1897 push @newkids, @front;
1898 for my $kid (@{$$self{Kids}}) {
1899 push @newkids, $kid->ast($self, @_);
1901 push @newkids, @back;
1902 return P5AST::op_stringify->new(Kids => [@newkids]);
1905 package PLXML::op_left_shift;
1906 package PLXML::op_right_shift;
1907 package PLXML::op_lt;
1908 package PLXML::op_i_lt;
1909 package PLXML::op_gt;
1910 package PLXML::op_i_gt;
1911 package PLXML::op_le;
1912 package PLXML::op_i_le;
1913 package PLXML::op_ge;
1914 package PLXML::op_i_ge;
1915 package PLXML::op_eq;
1916 package PLXML::op_i_eq;
1917 package PLXML::op_ne;
1918 package PLXML::op_i_ne;
1919 package PLXML::op_ncmp;
1920 package PLXML::op_i_ncmp;
1921 package PLXML::op_slt;
1922 package PLXML::op_sgt;
1923 package PLXML::op_sle;
1924 package PLXML::op_sge;
1925 package PLXML::op_seq;
1926 package PLXML::op_sne;
1927 package PLXML::op_scmp;
1928 package PLXML::op_bit_and;
1929 package PLXML::op_bit_xor;
1930 package PLXML::op_bit_or;
1931 package PLXML::op_negate;
1932 package PLXML::op_i_negate;
1933 package PLXML::op_not;
1937 my @newkids = $self->madness('o (');
1939 if (@newkids and $newkids[-1]->uni eq '!~') {
1944 if (exists $$self{Kids}) {
1945 my $arg = $$self{Kids}[0];
1946 push @newkids, $arg->ast($self, @_) if defined $arg;
1949 splice @{$newkids[-1][0]{Kids}}, -2, 0, @swap; # XXX WAG
1951 push @newkids, $self->madness(')');
1953 my $res = $self->newtype->new(Kids => [@newkids]);
1957 package PLXML::op_complement;
1958 package PLXML::op_atan2;
1959 package PLXML::op_sin;
1960 package PLXML::op_cos;
1961 package PLXML::op_rand;
1962 package PLXML::op_srand;
1963 package PLXML::op_exp;
1964 package PLXML::op_log;
1965 package PLXML::op_sqrt;
1966 package PLXML::op_int;
1967 package PLXML::op_hex;
1968 package PLXML::op_oct;
1969 package PLXML::op_abs;
1970 package PLXML::op_length;
1971 package PLXML::op_substr;
1972 package PLXML::op_vec;
1973 package PLXML::op_index;
1974 package PLXML::op_rindex;
1975 package PLXML::op_sprintf;
1976 package PLXML::op_formline;
1977 package PLXML::op_ord;
1978 package PLXML::op_chr;
1979 package PLXML::op_crypt;
1980 package PLXML::op_ucfirst;
1984 return $self->PLXML::listop::ast(@_);
1987 package PLXML::op_lcfirst;
1991 return $self->PLXML::listop::ast(@_);
1994 package PLXML::op_uc;
1998 return $self->PLXML::listop::ast(@_);
2001 package PLXML::op_lc;
2005 return $self->PLXML::listop::ast(@_);
2008 package PLXML::op_quotemeta;
2012 return $self->PLXML::listop::ast(@_);
2015 package PLXML::op_rv2av;
2019 return P5AST::op_rv2av->new(Kids => [$self->madness('$ @')]);
2025 if (ref $$self{Kids}[0] eq 'PLXML::op_const' and $$self{mp}{'O'}) {
2026 return $self->madness('O');
2030 push @before, $self->madness('dx d (');
2033 push @newkids, $self->madness('$ @ K');
2034 if (ref $$self{Kids}[0] ne "PLXML::op_gv") {
2035 push @newkids, $$self{Kids}[0]->ast();
2038 push @after, $self->madness(') a');
2039 return $self->newtype->new(Kids => [@before, @newkids, @after]);
2042 package PLXML::op_aelemfast;
2046 return $self->madness('$');
2049 package PLXML::op_aelem;
2054 push @newkids, $self->madness('dx d');
2055 for my $kid (@{$$self{Kids}}) {
2056 push @newkids, $kid->ast($self, @_);
2058 splice @newkids, -1, 0, $self->madness('a [');
2059 push @newkids, $self->madness(']');
2060 return P5AST::op_aelem->new(Kids => [@newkids]);
2066 my @before = $self->madness('dx d');
2068 for my $kid (@{$$self{Kids}}) {
2069 push @newkids, $kid->ast(@_);
2071 splice @newkids, -1, 0, $self->madness('a [');
2072 push @newkids, $self->madness(']');
2074 return $self->newtype->new(Kids => [@before, @newkids]);
2077 package PLXML::op_aslice;
2082 push @newkids, $self->madness('[');
2083 for my $kid (@{$$self{Kids}}) {
2084 push @newkids, $kid->ast(@_);
2086 unshift @newkids, pop @newkids;
2087 unshift @newkids, $self->madness('dx d');
2088 push @newkids, $self->madness(']');
2089 return P5AST::op_aslice->new(Kids => [@newkids]);
2096 push @newkids, $self->madness('[');
2097 for my $kid (@{$$self{Kids}}) {
2098 push @newkids, $kid->ast(@_);
2100 unshift @newkids, pop @newkids;
2101 unshift @newkids, $self->madness('dx d');
2102 push @newkids, $self->madness(']');
2104 return $self->newtype->new(Kids => [@newkids]);
2107 package PLXML::op_each;
2108 package PLXML::op_values;
2109 package PLXML::op_keys;
2110 package PLXML::op_delete;
2111 package PLXML::op_exists;
2112 package PLXML::op_rv2hv;
2116 return P5AST::op_rv2hv->new(Kids => [$self->madness('$')]);
2123 push @before, $self->madness('dx d (');
2126 push @newkids, $self->madness('$ @ % K');
2127 if (ref $$self{Kids}[0] ne "PLXML::op_gv") {
2128 push @newkids, $$self{Kids}[0]->ast();
2131 push @after, $self->madness(') a');
2132 return $self->newtype->new(Kids => [@before, @newkids, @after]);
2135 package PLXML::op_helem;
2139 local $::curstate; # hash subscript potentially a lineseq
2140 local $::curenc = $::curenc;
2143 push @newkids, $self->madness('dx d');
2144 for my $kid (@{$$self{Kids}}) {
2145 push @newkids, $kid->ast($self, @_);
2147 splice @newkids, -1, 0, $self->madness('a {');
2148 push @newkids, $self->madness('}');
2149 return P5AST::op_helem->new(Kids => [@newkids]);
2154 local $::curstate; # hash subscript potentially a lineseq
2155 local $::curenc = $::curenc;
2157 my @before = $self->madness('dx d');
2159 for my $kid (@{$$self{Kids}}) {
2160 push @newkids, $kid->ast($self, @_);
2162 splice @newkids, -1, 0, $self->madness('a {');
2163 push @newkids, $self->madness('}');
2165 return $self->newtype->new(Kids => [@before, @newkids]);
2169 package PLXML::op_hslice;
2174 push @newkids, $self->madness('{');
2175 for my $kid (@{$$self{Kids}}) {
2176 push @newkids, $kid->ast(@_);
2178 unshift @newkids, pop @newkids;
2179 unshift @newkids, $self->madness('dx d');
2180 push @newkids, $self->madness('}');
2181 return P5AST::op_hslice->new(Kids => [@newkids]);
2188 push @newkids, $self->madness('{');
2189 for my $kid (@{$$self{Kids}}) {
2190 push @newkids, $kid->ast(@_);
2192 unshift @newkids, pop @newkids;
2193 unshift @newkids, $self->madness('dx d');
2194 push @newkids, $self->madness('}');
2196 return $self->newtype->new(Kids => [@newkids]);
2199 package PLXML::op_unpack;
2200 package PLXML::op_pack;
2201 package PLXML::op_split;
2202 package PLXML::op_join;
2203 package PLXML::op_list;
2210 if (@retval = $self->madness('X')) {
2211 push @before, $self->madness('x o');
2212 return @before,@retval;
2214 my @kids = @{$$self{Kids}};
2215 for my $kid (@kids) {
2216 next if ref $kid eq 'PLXML::op_pushmark';
2217 next if ref $kid eq 'PLXML::op_null' and
2218 defined $$kid{was} and $$kid{was} eq 'pushmark';
2219 push @newkids, $kid->ast($self, @_);
2223 my @newnewkids = ();
2224 push @newnewkids, $self->madness('dx d (');
2225 push @newnewkids, @newkids;
2226 push @newnewkids, $self->madness(') :');
2227 return P5AST::op_list->new(Kids => [@newnewkids]);
2235 if (@retval = $self->madness('X')) {
2236 push @before, $self->madness('o');
2237 return $self->newtype->new(Kids => [@before,@retval]);
2239 push @retval, $self->madness('dx d (');
2242 for my $kid (@{$$self{Kids}}) {
2243 push @newkids, $kid->ast($self, @_);
2246 my @newnewkids = ();
2247 push @newnewkids, @newkids;
2248 @newkids = @newnewkids;
2249 push @retval, @newkids;
2250 push @retval, $self->madness(') :');
2251 return $self->newtype->new(Kids => [@retval]);
2254 package PLXML::op_lslice;
2260 if ($$self{mp}{q}) {
2261 push @newkids, $self->madness('q = Q');
2263 elsif ($$self{mp}{x}) {
2264 push @newkids, $self->madness('x');
2267 push @newkids, $self->madness('(');
2268 my $list = $$self{Kids}[1];
2269 push @newkids, $list->ast($self, @_);
2270 push @newkids, $self->madness(')');
2273 push @newkids, $self->madness('[');
2275 my $slice = $$self{Kids}[0];
2276 push @newkids, $slice->ast($self, @_);
2277 push @newkids, $self->madness(']');
2279 return $self->newtype->new(Kids => [@newkids]);
2282 package PLXML::op_anonlist;
2283 package PLXML::op_anonhash;
2284 package PLXML::op_splice;
2285 package PLXML::op_push;
2286 package PLXML::op_pop;
2287 package PLXML::op_shift;
2288 package PLXML::op_unshift;
2289 package PLXML::op_sort;
2290 package PLXML::op_reverse;
2294 $self->PLXML::listop::ast(@_);
2297 package PLXML::op_grepstart;
2298 package PLXML::op_grepwhile;
2299 package PLXML::op_mapstart;
2300 package PLXML::op_mapwhile;
2301 package PLXML::op_range;
2305 return $self->PLXML::binop::ast(@_);
2308 package PLXML::op_flip;
2309 package PLXML::op_flop;
2310 package PLXML::op_and;
2315 my @first = $self->madness('1');
2316 my @second = $self->madness('2');
2317 my @stuff = $$self{Kids}[0]->ast();
2318 if (my @I = $self->madness('I')) {
2321 push @newkids, $self->madness('(');
2322 push @newkids, @stuff;
2323 push @newkids, $self->madness(')');
2324 push @newkids, @second;
2328 push @newkids, $self->madness('(');
2329 push @newkids, @first;
2330 push @newkids, $self->madness(')');
2331 push @newkids, @stuff;
2334 elsif (my @i = $self->madness('i')) {
2336 push @newkids, @second;
2338 push @newkids, @stuff;
2341 push @newkids, @stuff;
2343 push @newkids, @first;
2346 elsif (my @o = $self->madness('o')) {
2348 push @newkids, @stuff;
2350 push @newkids, @second;
2353 push @newkids, @first;
2355 push @newkids, @stuff;
2358 return P5AST::op_and->new(Kids => [@newkids]);
2361 package PLXML::op_or;
2366 my @first = $self->madness('1');
2367 my @second = $self->madness('2');
2368 my @i = $self->madness('i');
2369 my @stuff = $$self{Kids}[0]->ast();
2372 push @newkids, @second;
2373 push @newkids, $self->madness('i');
2374 push @newkids, @stuff;
2377 push @newkids, @stuff;
2378 push @newkids, $self->madness('o');
2379 push @newkids, @second;
2384 push @newkids, @stuff;
2385 push @newkids, $self->madness('i');
2386 push @newkids, @first;
2389 push @newkids, @first;
2390 push @newkids, $self->madness('o');
2391 push @newkids, @stuff;
2394 return "P5AST::op_$$self{was}"->new(Kids => [@newkids]);
2398 package PLXML::op_xor;
2399 package PLXML::op_cond_expr;
2400 package PLXML::op_andassign;
2401 package PLXML::op_orassign;
2402 package PLXML::op_method;
2403 package PLXML::op_entersub;
2408 if ($$self{mp}{q}) {
2409 return $self->madness('q = Q');
2411 if ($$self{mp}{X}) { # <FH> override?
2412 return $self->madness('X');
2414 if ($$self{mp}{A}) {
2415 return $self->astmethod(@_);
2417 if ($$self{mp}{a}) {
2418 return $self->astarrow(@_);
2424 my @kids = @{$$self{Kids}};
2425 if (@kids == 1 and ref $kids[0] eq 'PLXML::op_null' and $kids[0]{was} =~ /list/) {
2426 @kids = @{$kids[0]{Kids}};
2428 my $dest = pop @kids;
2429 my @dest = $dest->ast($self, @_);
2431 if (ref($dest) =~ /method/) {
2432 my $invocant = shift @kids;
2433 $invocant = shift @kids if ref($invocant) eq 'PLXML::op_pushmark';
2434 my @invocant = $invocant->ast($self, @_);
2435 push @retval, @dest;
2436 push @retval, @invocant;
2438 elsif (exists $$self{mp}{o} and $$self{mp}{o} eq 'do') {
2439 push @retval, $self->madness('o');
2440 push @retval, @dest;
2443 push @retval, $self->madness('o');
2444 push @retval, @dest;
2447 my $kid = shift(@kids);
2448 push @newkids, $kid->ast($self, @_);
2451 push @retval, $self->madness('(');
2452 push @retval, @newkids;
2453 push @retval, $self->madness(')');
2454 return $self->newtype->new(Kids => [@retval]);
2461 for my $kid (@{$$self{Kids}}) {
2462 next if ref $kid eq 'PLXML::op_pushmark';
2463 next if ref $kid eq 'PLXML::op_null' and
2464 defined $$kid{was} and $$kid{was} eq 'pushmark';
2468 if ($$self{flags} =~ /\bSTACKED\b/) {
2469 push @invocant, shift(@kids)->ast($self, @_);
2471 for my $kid (@kids) {
2472 push @newkids, $kid->ast($self, @_);
2474 my $dest = pop(@newkids);
2475 if (ref $dest eq 'PLXML::op_rv2cv' and $$self{flags} =~ /\bMOD\b/) {
2476 $dest = pop(@newkids);
2480 push @retval, @invocant;
2481 push @retval, $self->madness('A');
2482 push @retval, $dest;
2483 push @retval, $self->madness('(');
2484 push @retval, @newkids;
2485 push @retval, $self->madness(')');
2486 return $self->newtype->new(Kids => [@retval]);
2493 my @kids = @{$$self{Kids}};
2494 if (@kids == 1 and ref $kids[0] eq 'PLXML::op_null' and $kids[0]{was} =~ /list/) {
2495 @kids = @{$kids[0]{Kids}};
2498 my $kid = shift(@kids);
2499 push @newkids, $kid->ast($self, @_);
2501 my @dest = $kids[0]->ast($self, @_);
2503 push @retval, @dest;
2504 push @retval, $self->madness('a');
2505 push @retval, $self->madness('(');
2506 push @retval, @newkids;
2507 push @retval, $self->madness(')');
2508 return $self->newtype->new(Kids => [@retval]);
2511 package PLXML::op_leavesub;
2515 if (ref $$self{Kids}[0] eq "PLXML::op_null") {
2516 return $$self{Kids}[0]->ast(@_);
2518 return $$self{Kids}[0]->blockast($self, @_);
2521 package PLXML::op_leavesublv;
2526 return $$self{Kids}[0]->blockast($self, @_);
2529 package PLXML::op_caller;
2530 package PLXML::op_warn;
2531 package PLXML::op_die;
2532 package PLXML::op_reset;
2533 package PLXML::op_lineseq;
2537 my @kids = @{$$self{Kids}};
2538 local $::curstate = 0; # (probably redundant, but that's okay)
2539 local $::prevstate = 0;
2540 local $::curenc = $::curenc;
2545 my $kid = shift @kids;
2546 my $thing = $kid->ast($self, @_);
2547 next unless defined $thing;
2548 if ($::curstate ne $::prevstate) {
2550 push @newstuff, $::prevstate->madness(';');
2551 push @{$newprev->{Kids}}, @newstuff if $newprev;
2554 $::prevstate = $::curstate;
2556 push @retval, $thing;
2558 elsif ($::prevstate) {
2559 push @newstuff, $thing;
2562 push @retval, $thing;
2566 push @newstuff, $::prevstate->madness(';');
2567 push @{$newprev->{Kids}}, @newstuff if $newprev;
2579 push @retval, $self->madness('{');
2581 my @newkids = $self->PLXML::op_lineseq::lineseq(@_);
2582 push @retval, @newkids;
2584 push @retval, $self->madness('; }');
2585 return $self->newtype->new(Kids => [@retval]);
2588 package PLXML::op_nextstate;
2590 sub newtype { return "P5AST::statement" }
2595 push @newkids, $self->madness('L');
2596 $::curstate = $self;
2597 return P5AST::statement->new(Kids => [@newkids]);
2604 push @newkids, $self->madness('L');
2605 $::curstate = $self;
2606 return $self->newtype->new(Kids => [@newkids]);
2610 package PLXML::op_dbstate;
2611 package PLXML::op_unstack;
2612 package PLXML::op_enter;
2616 package PLXML::op_leave;
2625 my $mad = $$self{mp}{FIRST} || "unknown";
2631 push @tmpkids, $self->{Kids};
2632 my $anddo = $$self{Kids}[-1]{Kids}[0]{Kids};
2633 eval { push @newkids, $anddo->[1]->ast($self,@_); };
2634 push @newkids, "[[[NOANDDO]]]" if $@;
2635 push @newkids, $self->madness('w');
2636 push @newkids, $anddo->[0]->ast($self,@_);
2638 return $self->newtype->new(Kids => [@newkids]);
2642 push @retval, $self->madness('o {');
2644 my @newkids = $self->PLXML::op_lineseq::lineseq(@_);
2645 push @retval, @newkids;
2646 push @retval, $self->madness(q/; }/);
2647 my $retval = $self->newtype->new(Kids => [@retval]);
2649 if ($$self{mp}{C}) {
2652 push @before, $self->madness('I ( C )');
2653 if ($$self{mp}{t}) {
2654 push @before, $self->madness('t');
2656 elsif ($$self{mp}{e}) {
2657 push @after, $self->madness('e');
2659 return P5AST::op_cond->new(Kids => [@before, $retval, @after]);
2666 package PLXML::op_scope;
2673 push @newkids, $self->madness('o');
2675 push @newkids, $self->madness('{');
2676 push @newkids, $self->PLXML::op_lineseq::lineseq(@_);
2677 push @newkids, $self->madness('; }');
2679 my @folded = $self->madness('C');
2681 my @t = $self->madness('t');
2682 my @e = $self->madness('e');
2684 return $self->newtype->new(
2686 $self->madness('I ('),
2688 $self->madness(')'),
2689 $self->newtype->new(Kids => [@newkids]),
2694 return $self->newtype->new(
2696 $self->madness('I ('),
2698 $self->madness(')'),
2700 $self->newtype->new(Kids => [@newkids])
2704 return $self->newtype->new(Kids => [@newkids]);
2707 package PLXML::op_enteriter;
2711 my (undef,$range,$var) = @{$self->{Kids}};
2713 push @retval, $self->madness('v');
2714 if (!@retval and defined $var) {
2715 push @retval, $var->ast($self,@_);
2720 if (ref $range eq 'PLXML::op_null' and $$self{flags} =~ /STACKED/) {
2721 my (undef,$min,$max) = @{$range->{Kids}};
2722 push @retval, $min->ast($self,@_);
2724 if (exists $$range{mp}{O}) { # deeply buried .. operator
2725 PLXML::prepreproc($$range{mp}{O});
2727 $$range{mp}{'O'}{Kids}[0]{Kids}[0]{Kids}[0]{Kids}[0]->madness('o')
2730 push @retval, '..'; # XXX missing whitespace
2732 push @retval, $max->ast($self,@_);
2736 push @retval, $range->ast($self,@_);
2738 return $self->newtype->new(Kids => [@retval]);
2741 package PLXML::op_iter;
2742 package PLXML::op_enterloop;
2747 package PLXML::op_leaveloop;
2754 my $enterloop = $$self{Kids}[0];
2755 my $nextthing = $$self{Kids}[1];
2757 if ($$self{mp}{W}) {
2758 push @retval, $self->madness('L');
2759 push @newkids, $self->madness('W d');
2761 if (ref $enterloop eq 'PLXML::op_enteriter') {
2762 my ($var,@rest) = @{$enterloop->ast($self,@_)->{Kids}};
2763 push @newkids, $var if $var;
2764 push @newkids, $self->madness('q ( x = Q');
2765 push @newkids, @rest;
2768 push @newkids, $self->madness('(');
2769 push @newkids, $enterloop->ast($self,@_);
2774 if (ref $nextthing eq 'PLXML::op_null') {
2775 if ($$nextthing{mp}{'1'}) {
2776 push @newkids, $nextthing->madness('1');
2777 push @newkids, $self->madness(')');
2778 push @newkids, $$nextthing{Kids}[0]->blockast($self,@_);
2780 elsif ($$nextthing{mp}{'2'}) {
2781 push @newkids, $$nextthing{Kids}[0]->ast($self,@_);
2782 push @newkids, $self->madness(')');
2783 push @newkids, $$nextthing{mp}{'2'}->blockast($self,@_);
2785 elsif ($$nextthing{mp}{'U'}) {
2786 push @newkids, $nextthing->ast($self,@_);
2789 # bypass the op_null
2790 $andor = $nextthing->{Kids}[0];
2792 push @newkids, $$andor{Kids}[0]->ast($self, @_);
2794 push @newkids, $self->madness(')');
2796 push @newkids, $$andor{Kids}[1]->blockast($self, @_);
2801 $andor = $nextthing;
2802 push @newkids, $nextthing->madness('O');
2803 push @newkids, $self->madness(')');
2804 push @newkids, $nextthing->blockast($self, @_);
2806 if ($$self{mp}{w}) {
2807 push @newkids, $self->madness('w');
2808 push @newkids, $enterloop->ast($self,@_);
2811 push @retval, @newkids;
2813 return $self->newtype->new(Kids => [@retval]);
2816 package PLXML::op_return;
2817 package PLXML::op_last;
2818 package PLXML::op_next;
2819 package PLXML::op_redo;
2820 package PLXML::op_dump;
2821 package PLXML::op_goto;
2822 package PLXML::op_exit;
2823 package PLXML::op_open;
2824 package PLXML::op_close;
2825 package PLXML::op_pipe_op;
2826 package PLXML::op_fileno;
2827 package PLXML::op_umask;
2828 package PLXML::op_binmode;
2829 package PLXML::op_tie;
2830 package PLXML::op_untie;
2831 package PLXML::op_tied;
2832 package PLXML::op_dbmopen;
2833 package PLXML::op_dbmclose;
2834 package PLXML::op_sselect;
2835 package PLXML::op_select;
2836 package PLXML::op_getc;
2837 package PLXML::op_read;
2838 package PLXML::op_enterwrite;
2839 package PLXML::op_leavewrite;
2840 package PLXML::op_prtf;
2841 package PLXML::op_print;
2842 package PLXML::op_sysopen;
2843 package PLXML::op_sysseek;
2844 package PLXML::op_sysread;
2845 package PLXML::op_syswrite;
2846 package PLXML::op_send;
2847 package PLXML::op_recv;
2848 package PLXML::op_eof;
2849 package PLXML::op_tell;
2850 package PLXML::op_seek;
2851 package PLXML::op_truncate;
2852 package PLXML::op_fcntl;
2853 package PLXML::op_ioctl;
2854 package PLXML::op_flock;
2855 package PLXML::op_socket;
2856 package PLXML::op_sockpair;
2857 package PLXML::op_bind;
2858 package PLXML::op_connect;
2859 package PLXML::op_listen;
2860 package PLXML::op_accept;
2861 package PLXML::op_shutdown;
2862 package PLXML::op_gsockopt;
2863 package PLXML::op_ssockopt;
2864 package PLXML::op_getsockname;
2865 package PLXML::op_getpeername;
2866 package PLXML::op_lstat;
2867 package PLXML::op_stat;
2868 package PLXML::op_ftrread;
2869 package PLXML::op_ftrwrite;
2870 package PLXML::op_ftrexec;
2871 package PLXML::op_fteread;
2872 package PLXML::op_ftewrite;
2873 package PLXML::op_fteexec;
2874 package PLXML::op_ftis;
2875 package PLXML::op_fteowned;
2876 package PLXML::op_ftrowned;
2877 package PLXML::op_ftzero;
2878 package PLXML::op_ftsize;
2879 package PLXML::op_ftmtime;
2880 package PLXML::op_ftatime;
2881 package PLXML::op_ftctime;
2882 package PLXML::op_ftsock;
2883 package PLXML::op_ftchr;
2884 package PLXML::op_ftblk;
2885 package PLXML::op_ftfile;
2886 package PLXML::op_ftdir;
2887 package PLXML::op_ftpipe;
2888 package PLXML::op_ftlink;
2889 package PLXML::op_ftsuid;
2890 package PLXML::op_ftsgid;
2891 package PLXML::op_ftsvtx;
2892 package PLXML::op_fttty;
2893 package PLXML::op_fttext;
2894 package PLXML::op_ftbinary;
2895 package PLXML::op_chdir;
2896 package PLXML::op_chown;
2897 package PLXML::op_chroot;
2898 package PLXML::op_unlink;
2899 package PLXML::op_chmod;
2900 package PLXML::op_utime;
2901 package PLXML::op_rename;
2902 package PLXML::op_link;
2903 package PLXML::op_symlink;
2904 package PLXML::op_readlink;
2905 package PLXML::op_mkdir;
2906 package PLXML::op_rmdir;
2907 package PLXML::op_open_dir;
2908 package PLXML::op_readdir;
2909 package PLXML::op_telldir;
2910 package PLXML::op_seekdir;
2911 package PLXML::op_rewinddir;
2912 package PLXML::op_closedir;
2913 package PLXML::op_fork;
2914 package PLXML::op_wait;
2915 package PLXML::op_waitpid;
2916 package PLXML::op_system;
2917 package PLXML::op_exec;
2918 package PLXML::op_kill;
2919 package PLXML::op_getppid;
2920 package PLXML::op_getpgrp;
2921 package PLXML::op_setpgrp;
2922 package PLXML::op_getpriority;
2923 package PLXML::op_setpriority;
2924 package PLXML::op_time;
2925 package PLXML::op_tms;
2926 package PLXML::op_localtime;
2927 package PLXML::op_gmtime;
2928 package PLXML::op_alarm;
2929 package PLXML::op_sleep;
2930 package PLXML::op_shmget;
2931 package PLXML::op_shmctl;
2932 package PLXML::op_shmread;
2933 package PLXML::op_shmwrite;
2934 package PLXML::op_msgget;
2935 package PLXML::op_msgctl;
2936 package PLXML::op_msgsnd;
2937 package PLXML::op_msgrcv;
2938 package PLXML::op_semget;
2939 package PLXML::op_semctl;
2940 package PLXML::op_semop;
2941 package PLXML::op_require;
2942 package PLXML::op_dofile;
2943 package PLXML::op_entereval;
2947 local $::curstate; # eval {} has own statement sequence
2948 return $self->SUPER::ast(@_);
2951 package PLXML::op_leaveeval;
2952 package PLXML::op_entertry;
2953 package PLXML::op_leavetry;
2958 return $self->PLXML::op_leave::ast(@_);
2961 package PLXML::op_ghbyname;
2962 package PLXML::op_ghbyaddr;
2963 package PLXML::op_ghostent;
2964 package PLXML::op_gnbyname;
2965 package PLXML::op_gnbyaddr;
2966 package PLXML::op_gnetent;
2967 package PLXML::op_gpbyname;
2968 package PLXML::op_gpbynumber;
2969 package PLXML::op_gprotoent;
2970 package PLXML::op_gsbyname;
2971 package PLXML::op_gsbyport;
2972 package PLXML::op_gservent;
2973 package PLXML::op_shostent;
2974 package PLXML::op_snetent;
2975 package PLXML::op_sprotoent;
2976 package PLXML::op_sservent;
2977 package PLXML::op_ehostent;
2978 package PLXML::op_enetent;
2979 package PLXML::op_eprotoent;
2980 package PLXML::op_eservent;
2981 package PLXML::op_gpwnam;
2982 package PLXML::op_gpwuid;
2983 package PLXML::op_gpwent;
2984 package PLXML::op_spwent;
2985 package PLXML::op_epwent;
2986 package PLXML::op_ggrnam;
2987 package PLXML::op_ggrgid;
2988 package PLXML::op_ggrent;
2989 package PLXML::op_sgrent;
2990 package PLXML::op_egrent;
2991 package PLXML::op_getlogin;
2992 package PLXML::op_syscall;
2993 package PLXML::op_lock;
2994 package PLXML::op_threadsv;
2995 package PLXML::op_setstate;
2996 package PLXML::op_method_named;
3000 return $self->madness('O');
3003 package PLXML::op_dor;
3007 $self->PLXML::op_or::astnull(@_);
3010 package PLXML::op_dorassign;
3011 package PLXML::op_custom;