This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
integrate changes#8243,8254,8255,8313,8314,8363,8383,8390,8416,
authorGurusamy Sarathy <gsar@cpan.org>
Tue, 30 Jan 2001 18:48:32 +0000 (18:48 +0000)
committerGurusamy Sarathy <gsar@cpan.org>
Tue, 30 Jan 2001 18:48:32 +0000 (18:48 +0000)
8417,8418,8419,8424,8427,8430,8441,8563 from mainline (TODO: b.t
now fails one test)

Subject: [PATCH] lvalue AUTOLOAD. No, really.

Subject: [PATCH] Interesting syntax idea
Make opens + bareword assigns do typeglob assigns.

Tests for #8254.

Subject: [PATCH @8269] Continue blocks and B::Deparse
Make the peephole optimizer to bypass more null ops and
and rewrite the deparse handling of continue blocks.

Subject: Re: [PATCH @8269] Continue blocks and B::Deparse
Doc tweak on #8313.

Subject: [PATCH @8344] Fix spurious GVSV OPpOUR_INTRO

Subject: [PATCH @8382] Remove FileHandle/IO dependence in t/io/openpid.t

Subject:  [PATCH perl@8269] Opcode.XS, fix memory leak

Subject: RE: [PATCH] [ID 20001223.002] lvalues in list context
Replace 10000 with RETVAL_MAX, and compute RETVAL_MAX
according to the platform.

Subject: [PATCH @8404] Consolidated lvalue sub changes

Subject: Re: [PATCH] [ID 20001223.002] lvalues in list context

Rename RETVAL_MAX to RETURN_UNLIMITED_NUMBER.

Subject: B::Concise -- an improved replacement for B::Terse

The B::Terse drop-in replacement wasn't quite drop-in.

The LVRET macro needed an aTHX.

Use the /^Perl_/-less form of is_lvalue_sub().

Subject: [PATCH @8545] [ID 20000808.005] OP_REFGEN as an lvalue

p4raw-link: @8314 on //depot/perl: 646bba827d867c3a9ec63754025d124b158b6337
p4raw-link: @8313 on //depot/perl: 58cccf98a8ed478d6cf084cb2de62268c379cbc6
p4raw-link: @8255 on //depot/perl: 26191e783d73bf5f223253769d4bfbf74617dc91
p4raw-link: @8254 on //depot/perl: d38a0a1467f89c02cbd16ebdc31b41c6b552f379
p4raw-link: @8243 on //depot/perl: d32f2495b04e916e41d6514e2a6126c7223b49c9

p4raw-id: //depot/maint-5.6/perl@8620
p4raw-integrated: from //depot/perl@8616 'copy in' ext/B/B/Lint.pm
(@4545..) t/io/openpid.t (@6903..) pod/perlsub.pod (@8228..)
ext/B/B/Terse.pm (@8424..) 'edit in' pp.h (@8430..) op.c
(@8442..) 'merge in' ext/B/B.pm (@8072..) pod/perldiag.pod
(@8244..) ext/B/B/Deparse.pm (@8313..) doop.c (@8385..)
p4raw-branched: from //depot/perl@8424 'branch in' ext/B/B/Concise.pm
p4raw-integrated: from //depot/perl@8424 'merge in' MANIFEST (@8267..)
p4raw-integrated: from //depot/perl@8418 'copy in' t/pragma/sub_lval.t
(@8417..)
p4raw-integrated: from //depot/perl@8417 'copy in' opcode.h pp.sym
pp_proto.h (@7123..) 'edit in' op.h (@8313..) pp.c (@8415..)
'merge in' opcode.pl (@8282..) pp_ctl.c (@8328..) embed.h
embed.pl proto.h (@8378..) pp_hot.c (@8382..) toke.c (@8413..)
p4raw-integrated: from //depot/perl@8390 'merge in'
ext/Opcode/Opcode.xs (@8127..)
p4raw-integrated: from //depot/perl@8363 'merge in' dump.c (@8289..)
p4raw-integrated: from //depot/perl@8014 'ignore' t/lib/b.t (@7721..)

28 files changed:
MANIFEST
doop.c
dump.c
embed.h
embed.pl
ext/B/B.pm
ext/B/B/Concise.pm [new file with mode: 0644]
ext/B/B/Deparse.pm
ext/B/B/Lint.pm
ext/B/B/Terse.pm
ext/Opcode/Opcode.xs
op.c
op.h
opcode.h
opcode.pl
pod/perldiag.pod
pod/perlsub.pod
pp.c
pp.h
pp.sym
pp_ctl.c
pp_hot.c
pp_proto.h
proto.h
t/io/openpid.t
t/lib/b.t
t/pragma/sub_lval.t
toke.c

index a6d81d4..3db0284 100644 (file)
--- a/MANIFEST
+++ b/MANIFEST
@@ -172,6 +172,7 @@ ext/B/B/Bblock.pm   Compiler basic block analysis support
 ext/B/B/Bytecode.pm    Compiler Bytecode backend
 ext/B/B/C.pm           Compiler C backend
 ext/B/B/CC.pm          Compiler CC backend
+ext/B/B/Concise.pm     Compiler Concise backend
 ext/B/B/Debug.pm       Compiler Debug backend
 ext/B/B/Deparse.pm     Compiler Deparse backend
 ext/B/B/Disassembler.pm        Compiler Disassembler backend
diff --git a/doop.c b/doop.c
index a47d6f3..f07a69a 100644 (file)
--- a/doop.c
+++ b/doop.c
@@ -1207,7 +1207,7 @@ Perl_do_kv(pTHX)
        dokeys = dovalues = TRUE;
 
     if (!hv) {
-       if (PL_op->op_flags & OPf_MOD) {        /* lvalue */
+       if (PL_op->op_flags & OPf_MOD || LVRET) {       /* lvalue */
            dTARGET;            /* make sure to clear its target here */
            if (SvTYPE(TARG) == SVt_PVLV)
                LvTARG(TARG) = Nullsv;
@@ -1226,7 +1226,7 @@ Perl_do_kv(pTHX)
        IV i;
        dTARGET;
 
-       if (PL_op->op_flags & OPf_MOD) {        /* lvalue */
+       if (PL_op->op_flags & OPf_MOD || LVRET) {       /* lvalue */
            if (SvTYPE(TARG) < SVt_PVLV) {
                sv_upgrade(TARG, SVt_PVLV);
                sv_magic(TARG, Nullsv, 'k', Nullch, 0);
diff --git a/dump.c b/dump.c
index 3fefd1a..49efb60 100644 (file)
--- a/dump.c
+++ b/dump.c
@@ -453,6 +453,7 @@ Perl_do_op_dump(pTHX_ I32 level, PerlIO *file, OP *o)
        }
        else if (o->op_type == OP_ENTERSUB ||
                 o->op_type == OP_RV2SV ||
+                o->op_type == OP_GVSV ||
                 o->op_type == OP_RV2AV ||
                 o->op_type == OP_RV2HV ||
                 o->op_type == OP_RV2GV ||
diff --git a/embed.h b/embed.h
index c7729e7..ca81634 100644 (file)
--- a/embed.h
+++ b/embed.h
 #define io_close               Perl_io_close
 #define invert                 Perl_invert
 #define is_gv_magical          Perl_is_gv_magical
+#define is_lvalue_sub          Perl_is_lvalue_sub
 #define is_uni_alnum           Perl_is_uni_alnum
 #define is_uni_alnumc          Perl_is_uni_alnumc
 #define is_uni_idfirst         Perl_is_uni_idfirst
 #define ck_open                        Perl_ck_open
 #define ck_repeat              Perl_ck_repeat
 #define ck_require             Perl_ck_require
+#define ck_return              Perl_ck_return
 #define ck_rfun                        Perl_ck_rfun
 #define ck_rvconst             Perl_ck_rvconst
 #define ck_sassign             Perl_ck_sassign
 #define io_close(a,b)          Perl_io_close(aTHX_ a,b)
 #define invert(a)              Perl_invert(aTHX_ a)
 #define is_gv_magical(a,b,c)   Perl_is_gv_magical(aTHX_ a,b,c)
+#define is_lvalue_sub()                Perl_is_lvalue_sub(aTHX)
 #define is_uni_alnum(a)                Perl_is_uni_alnum(aTHX_ a)
 #define is_uni_alnumc(a)       Perl_is_uni_alnumc(aTHX_ a)
 #define is_uni_idfirst(a)      Perl_is_uni_idfirst(aTHX_ a)
 #define ck_open(a)             Perl_ck_open(aTHX_ a)
 #define ck_repeat(a)           Perl_ck_repeat(aTHX_ a)
 #define ck_require(a)          Perl_ck_require(aTHX_ a)
+#define ck_return(a)           Perl_ck_return(aTHX_ a)
 #define ck_rfun(a)             Perl_ck_rfun(aTHX_ a)
 #define ck_rvconst(a)          Perl_ck_rvconst(aTHX_ a)
 #define ck_sassign(a)          Perl_ck_sassign(aTHX_ a)
 #define invert                 Perl_invert
 #define Perl_is_gv_magical     CPerlObj::Perl_is_gv_magical
 #define is_gv_magical          Perl_is_gv_magical
+#define Perl_is_lvalue_sub     CPerlObj::Perl_is_lvalue_sub
+#define is_lvalue_sub          Perl_is_lvalue_sub
 #define Perl_is_uni_alnum      CPerlObj::Perl_is_uni_alnum
 #define is_uni_alnum           Perl_is_uni_alnum
 #define Perl_is_uni_alnumc     CPerlObj::Perl_is_uni_alnumc
 #define ck_repeat              Perl_ck_repeat
 #define Perl_ck_require                CPerlObj::Perl_ck_require
 #define ck_require             Perl_ck_require
+#define Perl_ck_return         CPerlObj::Perl_ck_return
+#define ck_return              Perl_ck_return
 #define Perl_ck_rfun           CPerlObj::Perl_ck_rfun
 #define ck_rfun                        Perl_ck_rfun
 #define Perl_ck_rvconst                CPerlObj::Perl_ck_rvconst
index 4f6a969..fec38f3 100755 (executable)
--- a/embed.pl
+++ b/embed.pl
@@ -1592,6 +1592,7 @@ Ap        |char*  |instr          |const char* big|const char* little
 p      |bool   |io_close       |IO* io|bool not_implicit
 p      |OP*    |invert         |OP* cmd
 dp     |bool   |is_gv_magical  |char *name|STRLEN len|U32 flags
+p      |I32    |is_lvalue_sub
 Ap     |bool   |is_uni_alnum   |U32 c
 Ap     |bool   |is_uni_alnumc  |U32 c
 Ap     |bool   |is_uni_idfirst |U32 c
index dc4c4f7..5f2cc9b 100644 (file)
@@ -9,12 +9,17 @@ package B;
 use XSLoader ();
 require Exporter;
 @ISA = qw(Exporter);
+
+# walkoptree_slow comes from B.pm (you are there),
+# walkoptree comes from B.xs
 @EXPORT_OK = qw(minus_c ppname save_BEGINs
                class peekop cast_I32 cstring cchar hash threadsv_names
-               main_root main_start main_cv svref_2object opnumber amagic_generation
-               walkoptree walkoptree_slow walkoptree_exec walksymtable
+               main_root main_start main_cv svref_2object opnumber
+               amagic_generation
+               walkoptree_slow walkoptree walkoptree_exec walksymtable
                parents comppadlist sv_undef compile_stats timing_info
                begin_av init_av end_av);
+
 sub OPf_KIDS ();
 use strict;
 @B::SV::ISA = 'B::OBJECT';
diff --git a/ext/B/B/Concise.pm b/ext/B/B/Concise.pm
new file mode 100644 (file)
index 0000000..9f53955
--- /dev/null
@@ -0,0 +1,812 @@
+package B::Concise;
+# Copyright (C) 2000, 2001 Stephen McCamant. All rights reserved.
+# This program is free software; you can redistribute and/or modify it
+# under the same terms as Perl itself.
+
+our $VERSION = "0.50";
+use strict;
+use B qw(class ppname main_start main_root main_cv cstring svref_2object
+        SVf_IOK SVf_NOK SVf_POK OPf_KIDS);
+
+my %style = 
+  ("terse" =>
+   ["(?(#label =>\n)?)(*(    )*)#class (#addr) pp_#name "
+    . "(?([#targ])?) #svclass~(?((#svaddr))?)~#svval\n",
+    "(*(    )*)goto #class (#addr)\n",
+    "#class pp_#name"],
+   "concise" =>
+   ["#hyphseq2 (*(   (x( ;)x))*)<#classsym> "
+    . "#exname#arg(?([#targarglife])?)~#flags(?(/#private)?)(x(;~->#next)x)\n",
+    "  (*(    )*)     goto #seq\n",
+    "(?(<#seq>)?)#exname#arg(?([#targarglife])?)"],
+   "linenoise" =>
+   ["(x(;(*( )*))x)#noise#arg(?([#targarg])?)(x( ;\n)x)",
+    "gt_#seq ",
+    "(?(#seq)?)#noise#arg(?([#targarg])?)"],
+   "debug" =>
+   ["#class (#addr)\n\top_next\t\t#nextaddr\n\top_sibling\t#sibaddr\n\t"
+    . "op_ppaddr\tPL_ppaddr[OP_#NAME]\n\top_type\t\t#typenum\n\top_seq\t\t"
+    . "#seqnum\n\top_flags\t#flagval\n\top_private\t#privval\n"
+    . "(?(\top_first\t#firstaddr\n)?)(?(\top_last\t\t#lastaddr\n)?)"
+    . "(?(\top_sv\t\t#svaddr\n)?)",
+    "    GOTO #addr\n",
+    "#addr"],
+   "env" => [$ENV{B_CONCISE_FORMAT}, $ENV{B_CONCISE_GOTO_FORMAT},
+            $ENV{B_CONCISE_TREE_FORMAT}],
+  );
+
+my($format, $gotofmt, $treefmt);
+my $curcv;
+my($seq_base, $cop_seq_base);
+
+sub concise_cv {
+    my ($order, $cvref) = @_;
+    my $cv = svref_2object($cvref);
+    $curcv = $cv;
+    if ($order eq "exec") {
+       walk_exec($cv->START);
+    } elsif ($order eq "basic") {
+       walk_topdown($cv->ROOT, sub { $_[0]->concise($_[1]) }, 0);
+    } else {
+       print tree($cv->ROOT, 0)
+    }
+}
+
+my $start_sym = "\e(0"; # "\cN" sometimes also works
+my $end_sym   = "\e(B"; # "\cO" respectively
+
+my @tree_decorations = 
+  (["  ", "--", "+-", "|-", "| ", "`-", "-", 1],
+   [" ", "-", "+", "+", "|", "`", "", 0],
+   ["  ", map("$start_sym$_$end_sym", "qq", "wq", "tq", "x ", "mq", "q"), 1],
+   [" ", map("$start_sym$_$end_sym", "q", "w", "t", "x", "m"), "", 0],
+  );
+my $tree_style = 0;
+
+my $base = 36;
+my $big_endian = 1;
+
+my $order = "basic";
+
+sub compile {
+    my @options = grep(/^-/, @_);
+    my @args = grep(!/^-/, @_);
+    my $do_main = 0;
+    ($format, $gotofmt, $treefmt) = @{$style{"concise"}};
+    for my $o (@options) {
+       if ($o eq "-basic") {
+           $order = "basic";
+       } elsif ($o eq "-exec") {
+           $order = "exec";
+       } elsif ($o eq "-tree") {
+           $order = "tree";
+       } elsif ($o eq "-compact") {
+           $tree_style |= 1;
+       } elsif ($o eq "-loose") {
+           $tree_style &= ~1;
+       } elsif ($o eq "-vt") {
+           $tree_style |= 2;
+       } elsif ($o eq "-ascii") {
+           $tree_style &= ~2;
+       } elsif ($o eq "-main") {
+           $do_main = 1;
+       } elsif ($o =~ /^-base(\d+)$/) {
+           $base = $1;
+       } elsif ($o eq "-bigendian") {
+           $big_endian = 1;
+       } elsif ($o eq "-littleendian") {
+           $big_endian = 0;
+       } elsif (exists $style{substr($o, 1)}) {
+           ($format, $gotofmt, $treefmt) = @{$style{substr($o, 1)}};
+       } else {
+           warn "Option $o unrecognized";
+       }
+    }
+    if (@args) {
+       return sub {
+           for my $objname (@args) {
+               $objname = "main::" . $objname unless $objname =~ /::/;
+               eval "concise_cv(\$order, \\&$objname)";
+               die "concise_cv($order, \\&$objname) failed: $@" if $@;
+           }
+       }
+    }
+    if (!@args or $do_main) {
+       if ($order eq "exec") {
+           return sub { return if class(main_start) eq "NULL";
+                        $curcv = main_cv;
+                        walk_exec(main_start) }
+       } elsif ($order eq "tree") {
+           return sub { return if class(main_root) eq "NULL";
+                        $curcv = main_cv;
+                        print tree(main_root, 0) }
+       } elsif ($order eq "basic") {
+           return sub { return if class(main_root) eq "NULL";
+                        $curcv = main_cv;
+                        walk_topdown(main_root,
+                                     sub { $_[0]->concise($_[1]) }, 0); }
+       }
+    }
+}
+
+my %labels;
+my $lastnext;
+
+my %opclass = ('OP' => "0", 'UNOP' => "1", 'BINOP' => "2", 'LOGOP' => "|",
+              'LISTOP' => "@", 'PMOP' => "/", 'SVOP' => "\$", 'GVOP' => "*",
+              'PVOP' => '"', 'LOOP' => "{", 'COP' => ";");
+
+my @linenoise =
+  qw'#  () sc (  @? 1  $* gv *{ m$ m@ m% m? p/ *$ $  $# & a& pt \\ s\\ rf bl
+     `  *? <> ?? ?/ r/ c/ // qr s/ /c y/ =  @= C  sC Cp sp df un BM po +1 +I
+     -1 -I 1+ I+ 1- I- ** *  i* /  i/ %$ i% x  +  i+ -  i- .  "  << >> <  i<
+     >  i> <= i, >= i. == i= != i! <? i? s< s> s, s. s= s! s? b& b^ b| -0 -i
+     !  ~  a2 si cs rd sr e^ lg sq in %x %o ab le ss ve ix ri sf FL od ch cy
+     uf lf uc lc qm @  [f [  @[ eh vl ky dl ex %  ${ @{ uk pk st jn )  )[ a@
+     a% sl +] -] [- [+ so rv GS GW MS MW .. f. .f && || ^^ ?: &= |= -> s{ s}
+     v} ca wa di rs ;; ;  ;d }{ {  }  {} f{ it {l l} rt }l }n }r dm }g }e ^o
+     ^c ^| ^# um bm t~ u~ ~d DB db ^s se ^g ^r {w }w pf pr ^O ^K ^R ^W ^d ^v
+     ^e ^t ^k t. fc ic fl .s .p .b .c .l .a .h g1 s1 g2 s2 ?. l? -R -W -X -r
+     -w -x -e -o -O -z -s -M -A -C -S -c -b -f -d -p -l -u -g -k -t -T -B cd
+     co cr u. cm ut r. l@ s@ r@ mD uD oD rD tD sD wD cD f$ w$ p$ sh e$ k$ g3
+     g4 s4 g5 s5 T@ C@ L@ G@ A@ S@ Hg Hc Hr Hw Mg Mc Ms Mr Sg Sc So rq do {e
+     e} {t t} g6 G6 6e g7 G7 7e g8 G8 8e g9 G9 9e 6s 7s 8s 9s 6E 7E 8E 9E Pn
+     Pu GP SP EP Gn Gg GG SG EG g0 c$ lk t$ ;s n>';
+
+my $chars = "0123456789abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ";
+
+sub op_flags {
+    my($x) = @_;
+    my(@v);
+    push @v, "v" if ($x & 3) == 1;
+    push @v, "s" if ($x & 3) == 2;
+    push @v, "l" if ($x & 3) == 3;
+    push @v, "K" if $x & 4;
+    push @v, "P" if $x & 8;
+    push @v, "R" if $x & 16;
+    push @v, "M" if $x & 32;
+    push @v, "S" if $x & 64;
+    push @v, "*" if $x & 128;
+    return join("", @v);
+}
+
+sub base_n {
+    my $x = shift;
+    return "-" . base_n(-$x) if $x < 0;
+    my $str = "";
+    do { $str .= substr($chars, $x % $base, 1) } while $x = int($x / $base);
+    $str = reverse $str if $big_endian;
+    return $str;
+}
+
+sub seq { return $_[0]->seq ? base_n($_[0]->seq - $seq_base) : "-" }
+
+sub walk_topdown {
+    my($op, $sub, $level) = @_;
+    $sub->($op, $level);
+    if ($op->flags & OPf_KIDS) {
+       for (my $kid = $op->first; $$kid; $kid = $kid->sibling) {
+           walk_topdown($kid, $sub, $level + 1);
+       }
+    }
+    if (class($op) eq "PMOP" and $ {$op->pmreplroot}) {
+       walk_topdown($op->pmreplroot, $sub, $level + 1);
+    }
+}
+
+sub walklines {
+    my($ar, $level) = @_;
+    for my $l (@$ar) {
+       if (ref($l) eq "ARRAY") {
+           walklines($l, $level + 1);
+       } else {
+           $l->concise($level);
+       }
+    }
+}
+
+sub walk_exec {
+    my($top, $level) = @_;
+    my %opsseen;
+    my @lines;
+    my @todo = ([$top, \@lines]);
+    while (@todo and my($op, $targ) = @{shift @todo}) {
+       for (; $$op; $op = $op->next) {
+           last if $opsseen{$$op}++;
+           push @$targ, $op;
+           my $name = $op->name;
+           if ($name
+               =~ /^(or|and|(map|grep)while|entertry|range|cond_expr)$/) {
+               my $ar = [];
+               push @$targ, $ar;
+               push @todo, [$op->other, $ar];
+           } elsif ($name eq "subst" and $ {$op->pmreplstart}) {
+               my $ar = [];
+               push @$targ, $ar;
+               push @todo, [$op->pmreplstart, $ar];
+           } elsif ($name =~ /^enter(loop|iter)$/) {
+               $labels{$op->nextop->seq} = "NEXT";
+               $labels{$op->lastop->seq} = "LAST";
+               $labels{$op->redoop->seq} = "REDO";             
+           }
+       }
+    }
+    walklines(\@lines, 0);
+}
+
+sub fmt_line {
+    my($hr, $fmt, $level) = @_;
+    my $text = $fmt;
+    $text =~ s/\(\?\(([^\#]*?)\#(\w+)([^\#]*?)\)\?\)/
+      $hr->{$2} ? $1.$hr->{$2}.$3 : ""/eg;
+    $text =~ s/\(x\((.*?);(.*?)\)x\)/$order eq "exec" ? $1 : $2/egs;
+    $text =~ s/\(\*\(([^;]*?)\)\*\)/$1 x $level/egs;
+    $text =~ s/\(\*\((.*?);(.*?)\)\*\)/$1 x ($level - 1) . $2 x ($level>0)/egs;
+    $text =~ s/#([a-zA-Z]+)(\d+)/sprintf("%-$2s", $hr->{$1})/eg;
+    $text =~ s/#([a-zA-Z]+)/$hr->{$1}/eg;
+    $text =~ s/[ \t]*~+[ \t]*/ /g;
+    return $text;
+}
+
+my %priv;
+$priv{$_}{128} = "LVINTRO"
+  for ("pos", "substr", "vec", "threadsv", "gvsv", "rv2sv", "rv2hv", "rv2gv",
+       "rv2av", "rv2arylen", "aelem", "helem", "aslice", "hslice", "padsv",
+       "padav", "padhv");
+$priv{$_}{64} = "REFC" for ("leave", "leavesub", "leavesublv", "leavewrite");
+$priv{"aassign"}{64} = "COMMON";
+$priv{"aassign"}{32} = "PHASH";
+$priv{"sassign"}{64} = "BKWARD";
+$priv{$_}{64} = "RTIME" for ("match", "subst", "substcont");
+@{$priv{"trans"}}{1,2,4,8,16,64} = ("<UTF", ">UTF", "IDENT", "SQUASH", "DEL",
+                                   "COMPL", "GROWS");
+$priv{"repeat"}{64} = "DOLIST";
+$priv{"leaveloop"}{64} = "CONT";
+@{$priv{$_}}{32,64,96} = ("DREFAV", "DREFHV", "DREFSV")
+  for ("entersub", map("rv2${_}v", "a", "s", "h", "g"), "aelem", "helem");
+$priv{"entersub"}{16} = "DBG";
+$priv{"entersub"}{32} = "TARG";
+@{$priv{$_}}{4,8,128} = ("INARGS","AMPER","NO()") for ("entersub", "rv2cv");
+$priv{"gv"}{32} = "EARLYCV";
+$priv{"aelem"}{16} = $priv{"helem"}{16} = "LVDEFER";
+$priv{$_}{16} = "OURINTR" for ("gvsv", "rv2sv", "rv2av", "rv2hv", "r2gv");
+$priv{$_}{16} = "TARGMY"
+  for (map(($_,"s$_"),"chop", "chomp"),
+       map(($_,"i_$_"), "postinc", "postdec", "multiply", "divide", "modulo",
+          "add", "subtract", "negate"), "pow", "concat", "stringify",
+       "left_shift", "right_shift", "bit_and", "bit_xor", "bit_or",
+       "complement", "atan2", "sin", "cos", "rand", "exp", "log", "sqrt",
+       "int", "hex", "oct", "abs", "length", "index", "rindex", "sprintf",
+       "ord", "chr", "crypt", "quotemeta", "join", "push", "unshift", "flock",
+       "chdir", "chown", "chroot", "unlink", "chmod", "utime", "rename",
+       "link", "symlink", "mkdir", "rmdir", "wait", "waitpid", "system",
+       "exec", "kill", "getppid", "getpgrp", "setpgrp", "getpriority",
+       "setpriority", "time", "sleep");
+@{$priv{"const"}}{8,16,32,64,128} = ("STRICT","ENTERED", "$[", "BARE", "WARN");
+$priv{"flip"}{64} = $priv{"flop"}{64} = "LINENUM";
+$priv{"list"}{64} = "GUESSED";
+$priv{"delete"}{64} = "SLICE";
+$priv{"exists"}{64} = "SUB";
+$priv{$_}{64} = "LOCALE"
+  for ("sort", "prtf", "sprintf", "slt", "sle", "seq", "sne", "sgt", "sge",
+       "scmp", "lc", "uc", "lcfirst", "ucfirst");
+@{$priv{"sort"}}{1,2,4} = ("NUM", "INT", "REV");
+$priv{"threadsv"}{64} = "SVREFd";
+$priv{$_}{16} = "INBIN" for ("open", "backtick");
+$priv{$_}{32} = "INCR" for ("open", "backtick");
+$priv{$_}{64} = "OUTBIN" for ("open", "backtick");
+$priv{$_}{128} = "OUTCR" for ("open", "backtick");
+$priv{"exit"}{128} = "VMS";
+
+sub private_flags {
+    my($name, $x) = @_;
+    my @s;
+    for my $flag (128, 96, 64, 32, 16, 8, 4, 2, 1) {
+       if ($priv{$name}{$flag} and $x & $flag and $x >= $flag) {
+           $x -= $flag;
+           push @s, $priv{$name}{$flag};
+       }
+    }
+    push @s, $x if $x;
+    return join(",", @s);
+}
+
+sub concise_op {
+    my ($op, $level, $format) = @_;
+    my %h;
+    $h{exname} = $h{name} = $op->name;
+    $h{NAME} = uc $h{name};
+    $h{class} = class($op);
+    $h{extarg} = $h{targ} = $op->targ;
+    $h{extarg} = "" unless $h{extarg};
+    if ($h{name} eq "null" and $h{targ}) {
+       $h{exname} = "ex-" . substr(ppname($h{targ}), 3);
+       $h{extarg} = "";
+    } elsif ($h{targ}) {
+       my $padname = (($curcv->PADLIST->ARRAY)[0]->ARRAY)[$h{targ}];
+       if (defined $padname and class($padname) ne "SPECIAL") {
+           $h{targarg}  = $padname->PV;
+           my $intro = $padname->NVX - $cop_seq_base;
+           my $finish = int($padname->IVX) - $cop_seq_base;
+           $finish = "end" if $finish == 999999999 - $cop_seq_base;
+           $h{targarglife} = "$h{targarg}:$intro,$finish";
+       } else {
+           $h{targarglife} = $h{targarg} = "t" . $h{targ};
+       }
+    }
+    $h{arg} = "";
+    $h{svclass} = $h{svaddr} = $h{svval} = "";
+    if ($h{class} eq "PMOP") {
+       my $precomp = $op->precomp;
+       $precomp = defined($precomp) ? "/$precomp/" : "";
+       my $pmreplstart;
+       if ($ {$op->pmreplstart}) {
+           undef $lastnext;
+           $pmreplstart = "replstart->" . seq($op->pmreplstart);
+           $h{arg} = "(" . join(" ", $precomp, $pmreplstart) . ")";
+       } else {
+           $h{arg} = "($precomp)";
+       }
+    } elsif ($h{class} eq "PVOP" and $h{name} ne "trans") {
+       $h{arg} = '("' . $op->pv . '")';
+       $h{svval} = '"' . $op->pv . '"';
+    } elsif ($h{class} eq "COP") {
+       my $label = $op->label;
+       $label = $label ? "$label: " : "";
+       my $loc = $op->file;
+       $loc =~ s[.*/][];
+       $loc .= ":" . $op->line;
+       my($stash, $cseq) = ($op->stash->NAME, $op->cop_seq - $cop_seq_base);
+       my $arybase = $op->arybase;
+       $arybase = $arybase ? ' $[=' . $arybase : "";
+       $h{arg} = "($label$stash $cseq $loc$arybase)";
+    } elsif ($h{class} eq "LOOP") {
+       $h{arg} = "(next->" . seq($op->nextop) . " last->" . seq($op->lastop)
+         . " redo->" . seq($op->redoop) . ")";
+    } elsif ($h{class} eq "LOGOP") {
+       undef $lastnext;
+       $h{arg} = "(other->" . seq($op->other) . ")";
+    } elsif ($h{class} eq "SVOP") {
+       my $sv = $op->sv;
+       $h{svclass} = class($sv);
+       $h{svaddr} = sprintf("%#x", $$sv);
+       if ($h{svclass} eq "GV") {
+           my $gv = $sv;
+           my $stash = $gv->STASH->NAME;
+           if ($stash eq "main") {
+               $stash = "";
+           } else {
+               $stash = $stash . "::";
+           }
+           $h{arg} = "(*$stash" . $gv->NAME . ")";
+           $h{svval} = "*$stash" . $gv->NAME;
+       } else {
+           while (class($sv) eq "RV") {
+               $h{svval} .= "\\";
+               $sv = $sv->RV;
+           }
+           if (class($sv) eq "SPECIAL") {
+               $h{svval} = ["Null", "sv_undef", "sv_yes", "sv_no"]->[$$sv];
+           } elsif ($sv->FLAGS & SVf_NOK) {
+               $h{svval} = $sv->NV;
+           } elsif ($sv->FLAGS & SVf_IOK) {
+               $h{svval} = $sv->IV;
+           } elsif ($sv->FLAGS & SVf_POK) {
+               $h{svval} = cstring($sv->PV);
+           }
+           $h{arg} = "($h{svclass} $h{svval})";
+       }
+    }
+    $h{seq} = $h{hyphseq} = seq($op);
+    $h{seq} = "" if $h{seq} eq "-";
+    $h{seqnum} = $op->seq;
+    $h{next} = $op->next;
+    $h{next} = (class($h{next}) eq "NULL") ? "(end)" : seq($h{next});
+    $h{nextaddr} = sprintf("%#x", $ {$op->next});
+    $h{sibaddr} = sprintf("%#x", $ {$op->sibling});
+    $h{firstaddr} = sprintf("%#x", $ {$op->first}) if $op->can("first");
+    $h{lastaddr} = sprintf("%#x", $ {$op->last}) if $op->can("last");
+
+    $h{classsym} = $opclass{$h{class}};
+    $h{flagval} = $op->flags;
+    $h{flags} = op_flags($op->flags);
+    $h{privval} = $op->private;
+    $h{private} = private_flags($h{name}, $op->private);
+    $h{addr} = sprintf("%#x", $$op);
+    $h{label} = $labels{$op->seq};
+    $h{typenum} = $op->type;
+    $h{noise} = $linenoise[$op->type];
+    return fmt_line(\%h, $format, $level);
+}
+
+sub B::OP::concise {
+    my($op, $level) = @_;
+    if ($order eq "exec" and $lastnext and $$lastnext != $$op) {
+       my $h = {"seq" => seq($lastnext), "class" => class($lastnext),
+                "addr" => sprintf("%#x", $$lastnext)};
+       print fmt_line($h, $gotofmt, $level+1);
+    }
+    $lastnext = $op->next;
+    print concise_op($op, $level, $format);
+}
+
+sub tree {
+    my $op = shift;
+    my $level = shift;
+    my $style = $tree_decorations[$tree_style];
+    my($space, $single, $kids, $kid, $nokid, $last, $lead, $size) = @$style;
+    my $name = concise_op($op, $level, $treefmt);
+    if (not $op->flags & OPf_KIDS) {
+       return $name . "\n";
+    }
+    my @lines;
+    for (my $kid = $op->first; $$kid; $kid = $kid->sibling) {
+       push @lines, tree($kid, $level+1);
+    }
+    my $i;
+    for ($i = $#lines; substr($lines[$i], 0, 1) eq " "; $i--) {
+       $lines[$i] = $space . $lines[$i];
+    }
+    if ($i > 0) {
+       $lines[$i] = $last . $lines[$i];
+       while ($i-- > 1) {
+           if (substr($lines[$i], 0, 1) eq " ") {
+               $lines[$i] = $nokid . $lines[$i];
+           } else {
+               $lines[$i] = $kid . $lines[$i];         
+           }
+       }
+       $lines[$i] = $kids . $lines[$i];
+    } else {
+       $lines[0] = $single . $lines[0];
+    }
+    return("$name$lead" . shift @lines,
+           map(" " x (length($name)+$size) . $_, @lines));
+}
+
+# This is a bit of a hack; the 2 and 15 were determined empirically.
+# These need to stay the last things in the module.
+$cop_seq_base = svref_2object(eval 'sub{0;}')->START->cop_seq + 2;
+$seq_base = svref_2object(eval 'sub{}')->START->seq + 15;
+
+1;
+
+__END__
+
+=head1 NAME
+
+B::Concise - Walk Perl syntax tree, printing concise info about ops
+
+=head1 SYNOPSIS
+
+    perl -MO=Concise[,OPTIONS] foo.pl
+
+=head1 DESCRIPTION
+
+This compiler backend prints the internal OPs of a Perl program's syntax
+tree in one of several space-efficient text formats suitable for debugging
+the inner workings of perl or other compiler backends. It can print OPs in
+the order they appear in the OP tree, in the order they will execute, or
+in a text approximation to their tree structure, and the format of the
+information displyed is customizable. Its function is similar to that of
+perl's B<-Dx> debugging flag or the B<B::Terse> module, but it is more
+sophisticated and flexible.
+
+=head1 OPTIONS
+
+Arguments that don't start with a hyphen are taken to be the names of
+subroutines to print the OPs of; if no such functions are specified, the
+main body of the program (outside any subroutines, and not including use'd
+or require'd files) is printed.
+
+=over 4
+
+=item B<-basic>
+
+Print OPs in the order they appear in the OP tree (a preorder
+traversal, starting at the root). The indentation of each OP shows its
+level in the tree.  This mode is the default, so the flag is included
+simply for completeness.
+
+=item B<-exec>
+
+Print OPs in the order they would normally execute (for the majority
+of constructs this is a postorder traversal of the tree, ending at the
+root). In most cases the OP that usually follows a given OP will
+appear directly below it; alternate paths are shown by indentation. In
+cases like loops when control jumps out of a linear path, a 'goto'
+line is generated.
+
+=item B<-tree>
+
+Print OPs in a text approximation of a tree, with the root of the tree
+at the left and 'left-to-right' order of children transformed into
+'top-to-bottom'. Because this mode grows both to the right and down,
+it isn't suitable for large programs (unless you have a very wide
+terminal).
+
+=item B<-compact>
+
+Use a tree format in which the minimum amount of space is used for the
+lines connecting nodes (one character in most cases). This squeezes out
+a few precious columns of screen real estate.
+
+=item B<-loose>
+
+Use a tree format that uses longer edges to separate OP nodes. This format
+tends to look better than the compact one, especially in ASCII, and is
+the default.
+
+=item B<-vt>
+
+Use tree connecting characters drawn from the VT100 line-drawing set.
+This looks better if your terminal supports it.
+
+=item B<-ascii>
+
+Draw the tree with standard ASCII characters like C<+> and C<|>. These don't
+look as clean as the VT100 characters, but they'll work with almost any
+terminal (or the horizontal scrolling mode of less(1)) and are suitable
+for text documentation or email. This is the default.
+
+=item B<-main>
+
+Include the main program in the output, even if subroutines were also
+specified.
+
+=item B<-base>I<n>
+
+Print OP sequence numbers in base I<n>. If I<n> is greater than 10, the
+digit for 11 will be 'a', and so on. If I<n> is greater than 36, the digit
+for 37 will be 'A', and so on until 62. Values greater than 62 are not
+currently supported. The default is 36.
+
+=item B<-bigendian>
+
+Print sequence numbers with the most significant digit first. This is the
+usual convention for Arabic numerals, and the default.
+
+=item B<-littleendian>
+
+Print seqence numbers with the least significant digit first.
+
+=item B<-concise>
+
+Use the author's favorite set of formatting conventions. This is the
+default, of course.
+
+=item B<-terse>
+
+Use formatting conventions that emulate the ouput of B<B::Terse>. The
+basic mode is almost indistinguishable from the real B<B::Terse>, and the
+exec mode looks very similar, but is in a more logical order and lacks
+curly brackets. B<B::Terse> doesn't have a tree mode, so the tree mode
+is only vaguely reminiscient of B<B::Terse>.
+
+=item B<-linenoise>
+
+Use formatting conventions in which the name of each OP, rather than being
+written out in full, is represented by a one- or two-character abbreviation.
+This is mainly a joke.
+
+=item B<-debug>
+
+Use formatting conventions reminiscient of B<B::Debug>; these aren't
+very concise at all.
+
+=item B<-env>
+
+Use formatting conventions read from the environment variables
+C<B_CONCISE_FORMAT>, C<B_CONCISE_GOTO_FORMAT>, and C<B_CONCISE_TREE_FORMAT>.
+
+=back
+
+=head1 FORMATTING SPECIFICATIONS
+
+For each general style ('concise', 'terse', 'linenoise', etc.) there are
+three specifications: one of how OPs should appear in the basic or exec
+modes, one of how 'goto' lines should appear (these occur in the exec
+mode only), and one of how nodes should appear in tree mode. Each has the
+same format, described below. Any text that doesn't match a special
+pattern is copied verbatim.
+
+=over 4
+
+=item B<(x(>I<exec_text>B<;>I<basic_text>B<)x)>
+
+Generates I<exec_text> in exec mode, or I<basic_text> in basic mode.
+
+=item B<(*(>I<text>B<)*)>
+
+Generates one copy of I<text> for each indentation level.
+
+=item B<(*(>I<text1>B<;>I<text2>B<)*)>
+
+Generates one fewer copies of I<text1> than the indentation level, followed
+by one copy of I<text2> if the indentation level is more than 0.
+
+=item B<(?(>I<text1>B<#>I<var>I<Text2>B<)?)>
+
+If the value of I<var> is true (not empty or zero), generates the
+value of I<var> surrounded by I<text1> and I<Text2>, otherwise
+nothing.
+
+=item B<#>I<var>
+
+Generates the value of the variable I<var>.
+
+=item B<#>I<var>I<N>
+
+Generates the value of I<var>, left jutified to fill I<N> spaces.
+
+=item B<~>
+
+Any number of tildes and surrounding whitespace will be collapsed to
+a single space.
+
+=back
+
+The following variables are recognized:
+
+=over 4
+
+=item B<#addr>
+
+The address of the OP, in hexidecimal.
+
+=item B<#arg>
+
+The OP-specific information of the OP (such as the SV for an SVOP, the
+non-local exit pointers for a LOOP, etc.) enclosed in paretheses.
+
+=item B<#class>
+
+The B-determined class of the OP, in all caps.
+
+=item B<#classym>
+
+A single symbol abbreviating the class of the OP.
+
+=item B<#exname>
+
+The name of the OP, or 'ex-foo' if the OP is a null that used to be a foo.
+
+=item B<#extarg>
+
+The target of the OP, or nothing for a nulled OP.
+
+=item B<#firstaddr>
+
+The address of the OP's first child, in hexidecimal.
+
+=item B<#flags>
+
+The OP's flags, abbreviated as a series of symbols.
+
+=item B<#flagval>
+
+The numeric value of the OP's flags.
+
+=item B<#hyphenseq>
+
+The sequence number of the OP, or a hyphen if it doesn't have one.
+
+=item B<#label>
+
+'NEXT', 'LAST', or 'REDO' if the OP is a target of one of those in exec
+mode, or empty otherwise.
+
+=item B<#lastaddr>
+
+The address of the OP's last child, in hexidecimal.
+
+=item B<#name>
+
+The OP's name.
+
+=item B<#NAME>
+
+The OP's name, in all caps.
+
+=item B<#next>
+
+The sequence number of the OP's next OP.
+
+=item B<#nextaddr>
+
+The address of the OP's next OP, in hexidecimal.
+
+=item B<#noise>
+
+The two-character abbreviation for the OP's name.
+
+=item B<#private>
+
+The OP's private flags, rendered with abbreviated names if possible.
+
+=item B<#privval>
+
+The numeric value of the OP's private flags.
+
+=item B<#seq>
+
+The sequence number of the OP.
+
+=item B<#seqnum>
+
+The real sequence number of the OP, as a regular number and not adjusted
+to be relative to the start of the real program. (This will generally be
+a fairly large number because all of B<B::Concise> is compiled before
+your program is).
+
+=item B<#sibaddr>
+
+The address of the OP's next youngest sibling, in hexidecimal.
+
+=item B<#svaddr>
+
+The address of the OP's SV, if it has an SV, in hexidecimal.
+
+=item B<#svclass>
+
+The class of the OP's SV, if it has one, in all caps (e.g., 'IV').
+
+=item B<#svval>
+
+The value of the OP's SV, if it has one, in a short human-readable format.
+
+=item B<#targ>
+
+The numeric value of the OP's targ.
+
+=item B<#targarg>
+
+The name of the variable the OP's targ refers to, if any, otherwise the
+letter t followed by the OP's targ in decimal.
+
+=item B<#targarglife>
+
+Same as B<#targarg>, but followed by the COP sequence numbers that delimit
+the variable's lifetime (or 'end' for a variable in an open scope) for a
+variable.
+
+=item B<#typenum>
+
+The numeric value of the OP's type, in decimal.
+
+=back
+
+=head1 ABBREVIATIONS
+
+=head2 OP flags abbreviations
+
+    v      OPf_WANT_VOID    Want nothing (void context)
+    s      OPf_WANT_SCALAR  Want single value (scalar context)
+    l      OPf_WANT_LIST    Want list of any length (list context)
+    K      OPf_KIDS         There is a firstborn child.
+    P      OPf_PARENS       This operator was parenthesized.
+                             (Or block needs explicit scope entry.)
+    R      OPf_REF          Certified reference.
+                             (Return container, not containee).
+    M      OPf_MOD          Will modify (lvalue).
+    S      OPf_STACKED      Some arg is arriving on the stack.
+    *      OPf_SPECIAL      Do something weird for this op (see op.h)
+
+=head2 OP class abbreviations
+
+    0      OP (aka BASEOP)  An OP with no children
+    1      UNOP             An OP with one child
+    2      BINOP            An OP with two children
+    |      LOGOP            A control branch OP
+    @      LISTOP           An OP that could have lots of children
+    /      PMOP             An OP with a regular expression
+    $      SVOP             An OP with an SV
+    "      PVOP             An OP with a string
+    {      LOOP             An OP that holds pointers for a loop
+    ;      COP              An OP that marks the start of a statement
+
+=head1 AUTHOR
+
+Stephen McCamant, C<smcc@CSUA.Berkeley.EDU>
+
+=cut
index 5c5c5eb..4762832 100644 (file)
@@ -17,7 +17,7 @@ use B qw(class main_root main_start main_cv svref_2object opnumber
          CVf_METHOD CVf_LOCKED CVf_LVALUE
         PMf_KEEP PMf_GLOBAL PMf_CONTINUE PMf_EVAL PMf_ONCE
         PMf_MULTILINE PMf_SINGLELINE PMf_FOLD PMf_EXTENDED);
-$VERSION = 0.591;
+$VERSION = 0.60;
 use strict;
 
 # Changes between 0.50 and 0.51:
@@ -83,6 +83,12 @@ use strict;
 # - added support for Chip's OP_METHOD_NAMED
 # - added support for Ilya's OPpTARGET_MY optimization
 # - elided arrows before `()' subscripts when possible
+# Changes between 0.59 and 0.60
+# - support for method attribues was added
+# - some warnings fixed
+# - separate recognition of constant subs
+# - rewrote continue block handling, now recoginizing for loops
+# - added more control of expanding control structures
 
 # Todo:
 # - finish tr/// changes
@@ -93,8 +99,8 @@ use strict;
 # - left/right context
 # - recognize `use utf8', `use integer', etc
 # - treat top-level block specially for incremental output
-# - interpret in high bit chars in string as utf8 \x{...} (when?)
-# - copy comments (look at real text with $^P?) 
+# - interpret high bit chars in string as utf8 \x{...} (when?)
+# - copy comments (look at real text with $^P?)
 # - avoid semis in one-statement blocks
 # - associativity of &&=, ||=, ?:
 # - ',' => '=>' (auto-unquote?)
@@ -108,7 +114,6 @@ use strict;
 # - version using op_next instead of op_first/sibling?
 # - avoid string copies (pass arrays, one big join?)
 # - auto-apply `-u'?
-# - while{} with one-statement continue => for(; XXX; XXX) {}?
 # - -uPackage:: descend recursively?
 # - here-docs?
 # - <DATA>?
@@ -357,6 +362,8 @@ sub new {
            $self->{'unquote'} = 1;
        } elsif (substr($arg, 0, 2) eq "-s") {
            $self->style_opts(substr $arg, 2);
+       } elsif ($arg =~ /^-x(\d)$/) {
+           $self->{'expand'} = $1;
        }
     }
     return $self;
@@ -393,6 +400,7 @@ sub deparse {
     my $self = shift;
     my($op, $cx) = @_;
 #    cluck if class($op) eq "NULL";
+#    cluck unless $op;
 #    return $self->$ {\("pp_" . $op->name)}($op, $cx);
     my $meth = "pp_" . $op->name;
     return $self->$meth($op, $cx);
@@ -679,70 +687,69 @@ sub pp_entertry { # see also leavetry
     return "XXX";
 }
 
-# leave and scope/lineseq should probably share code
-sub pp_leave {
+sub lineseq {
     my $self = shift;
-    my($op, $cx) = @_;
-    my ($kid, $expr);
-    my @exprs;
-    local($self->{'curstash'}) = $self->{'curstash'};
-    $kid = $op->first->sibling; # skip enter
-    if (is_miniwhile($kid)) {
-       my $top = $kid->first;
-       my $name = $top->name;
-       if ($name eq "and") {
-           $name = "while";
-       } elsif ($name eq "or") {
-           $name = "until";
-       } else { # no conditional -> while 1 or until 0
-           return $self->deparse($top->first, 1) . " while 1";
-       }
-       my $cond = $top->first;
-       my $body = $cond->sibling->first; # skip lineseq
-       $cond = $self->deparse($cond, 1);
-       $body = $self->deparse($body, 1);
-       return "$body $name $cond";
-    }
-    for (; !null($kid); $kid = $kid->sibling) {
+    my(@ops) = @_;
+    my($expr, @exprs);
+    for (my $i = 0; $i < @ops; $i++) {
        $expr = "";
-       if (is_state $kid) {
-           $expr = $self->deparse($kid, 0);
-           $kid = $kid->sibling;
-           last if null $kid;
+       if (is_state $ops[$i]) {
+           $expr = $self->deparse($ops[$i], 0);
+           $i++;
+           last if $i > $#ops;
        }
-       $expr .= $self->deparse($kid, 0);
+       if (!is_state $ops[$i] and $ops[$i+1] and !null($ops[$i+1]) and
+           $ops[$i+1]->name eq "leaveloop" and $self->{'expand'} < 3)
+       {
+           push @exprs, $expr . $self->for_loop($ops[$i], 0);
+           $i++;
+           next;
+       }
+       $expr .= $self->deparse($ops[$i], 0);
        push @exprs, $expr if length $expr;
     }
-    if ($cx > 0) { # inside an expression
-       return "do { " . join(";\n", @exprs) . " }";
-    } else {
-       return join(";\n", @exprs) . ";";
-    }
+    return join(";\n", @exprs);
 }
 
-sub pp_scope {
-    my $self = shift;
-    my($op, $cx) = @_;
-    my ($kid, $expr);
-    my @exprs;
-    for ($kid = $op->first; !null($kid); $kid = $kid->sibling) {
-       $expr = "";
-       if (is_state $kid) {
-           $expr = $self->deparse($kid, 0);
-           $kid = $kid->sibling;
-           last if null $kid;
+sub scopeop {
+    my($real_block, $self, $op, $cx) = @_;
+    my $kid;
+    my @kids;
+    local($self->{'curstash'}) = $self->{'curstash'} if $real_block;
+    if ($real_block) {
+       $kid = $op->first->sibling; # skip enter
+       if (is_miniwhile($kid)) {
+           my $top = $kid->first;
+           my $name = $top->name;
+           if ($name eq "and") {
+               $name = "while";
+           } elsif ($name eq "or") {
+               $name = "until";
+           } else { # no conditional -> while 1 or until 0
+               return $self->deparse($top->first, 1) . " while 1";
+           }
+           my $cond = $top->first;
+           my $body = $cond->sibling->first; # skip lineseq
+           $cond = $self->deparse($cond, 1);
+           $body = $self->deparse($body, 1);
+           return "$body $name $cond";
        }
-       $expr .= $self->deparse($kid, 0);
-       push @exprs, $expr if length $expr;
+    } else {
+       $kid = $op->first;
+    }
+    for (; !null($kid); $kid = $kid->sibling) {
+       push @kids, $kid;
     }
     if ($cx > 0) { # inside an expression, (a do {} while for lineseq)
-       return "do { " . join(";\n", @exprs) . " }";
+       return "do { " . $self->lineseq(@kids) . " }";
     } else {
-       return join(";\n", @exprs) . ";";
+       return $self->lineseq(@kids) . ";";
     }
 }
 
-sub pp_lineseq { pp_scope(@_) }
+sub pp_scope { scopeop(0, @_); }
+sub pp_lineseq { scopeop(0, @_); }
+sub pp_leave { scopeop(1, @_); }
 
 # The BEGIN {} is used here because otherwise this code isn't executed
 # when you run B::Deparse on itself.
@@ -1380,11 +1387,14 @@ sub logop {
     my ($op, $cx, $lowop, $lowprec, $highop, $highprec, $blockname) = @_;
     my $left = $op->first;
     my $right = $op->first->sibling;
-    if ($cx == 0 and is_scope($right) and $blockname) { # if ($a) {$b}
+    if ($cx == 0 and is_scope($right) and $blockname
+       and $self->{'expand'} < 7)
+    { # if ($a) {$b}
        $left = $self->deparse($left, 1);
        $right = $self->deparse($right, 0);
        return "$blockname ($left) {\n\t$right\n\b}\cK";
-    } elsif ($cx == 0 and $blockname and not $self->{'parens'}) { # $b if $a
+    } elsif ($cx == 0 and $blockname and not $self->{'parens'}
+            and $self->{'expand'} < 7) { # $b if $a
        $right = $self->deparse($right, 1);
        $left = $self->deparse($left, 1);
        return "$right $blockname $left";
@@ -1675,7 +1685,8 @@ sub pp_cond_expr {
     my $false = $true->sibling;
     my $cuddle = $self->{'cuddle'};
     unless ($cx == 0 and (is_scope($true) and $true->name ne "null") and
-           (is_scope($false) || is_ifelse_cont($false))) {
+           (is_scope($false) || is_ifelse_cont($false))
+           and $self->{'expand'} < 7) {
        $cond = $self->deparse($cond, 8);
        $true = $self->deparse($true, 8);
        $false = $self->deparse($false, 8);
@@ -1704,20 +1715,24 @@ sub pp_cond_expr {
     return $head . join($cuddle, "", @elsifs) . $false; 
 }
 
-sub pp_leaveloop {
+sub loop_common {
     my $self = shift;
-    my($op, $cx) = @_;
+    my($op, $cx, $init) = @_;
     my $enter = $op->first;
     my $kid = $enter->sibling;
     local($self->{'curstash'}) = $self->{'curstash'};
     my $head = "";
     my $bare = 0;
+    my $body;
+    my $cond = undef;
     if ($kid->name eq "lineseq") { # bare or infinite loop 
        if (is_state $kid->last) { # infinite
            $head = "for (;;) "; # shorter than while (1)
+           $cond = "";
        } else {
            $bare = 1;
        }
+       $body = $kid;
     } elsif ($enter->name eq "enteriter") { # foreach
        my $ary = $enter->first->sibling; # first was pushmark
        my $var = $ary->sibling;
@@ -1749,62 +1764,60 @@ sub pp_leaveloop {
            $var = "\$" . $self->deparse($var, 1);
        }
        $head = "foreach $var ($ary) ";
-       $kid = $kid->first->first->sibling; # skip OP_AND and OP_ITER
+       $body = $kid->first->first->sibling; # skip OP_AND and OP_ITER
     } elsif ($kid->name eq "null") { # while/until
        $kid = $kid->first;
-       my $name = {"and" => "while", "or" => "until"}
-                   ->{$kid->name};
-       $head = "$name (" . $self->deparse($kid->first, 1) . ") ";
-       $kid = $kid->first->sibling;
+       my $name = {"and" => "while", "or" => "until"}->{$kid->name};
+       $cond = $self->deparse($kid->first, 1);
+       $head = "$name ($cond) ";
+       $body = $kid->first->sibling;
     } elsif ($kid->name eq "stub") { # bare and empty
        return "{;}"; # {} could be a hashref
     }
-    # The third-to-last kid is the continue block if the pointer used
-    # by `next BLOCK' points to its first OP, which happens to be the
-    # the op_next of the head of the _previous_ statement. 
-    # Unless it's a bare loop, in which case it's last, since there's
-    # no unstack or extra nextstate.
-    # Except if the previous head isn't null but the first kid is
-    # (because it's a nulled out nextstate in a scope), in which
-    # case the head's next is advanced past the null but the nextop's
-    # isn't, so we need to try nextop->next.
-    my $precont;
-    my $cont = $kid->first;
-    if ($bare) {
-       while (!null($cont->sibling)) {
-           $precont = $cont;
-           $cont = $cont->sibling;
-       }       
-    } else {
-       while (!null($cont->sibling->sibling->sibling)) {
-           $precont = $cont;
-           $cont = $cont->sibling;
+    # If there isn't a continue block, then the next pointer for the loop
+    # will point to the unstack, which is kid's penultimate child, except
+    # in a bare loop, when it will point to the leaveloop. When neither of
+    # these conditions hold, then the third-to-last child in the continue
+    # block (or the last in a bare loop).
+    my $cont_start = $enter->nextop;
+    my $cont;
+    if ($$cont_start != $$op and $ {$cont_start->sibling} != $ {$body->last}) {
+       if ($bare) {
+           $cont = $body->last;
+       } else {
+           $cont = $body->first;
+           while (!null($cont->sibling->sibling->sibling)) {
+               $cont = $cont->sibling;
+           }
+       }
+       my $state = $body->first;
+       my $cuddle = $self->{'cuddle'};
+       my @states;
+       for (; $$state != $$cont; $state = $state->sibling) {
+           push @states, $state;
+       }
+       $body = $self->lineseq(@states);
+       if (defined $cond and not is_scope $cont and $self->{'expand'} < 3) {
+           $head = "for ($init; $cond; " . $self->deparse($cont, 1) .") ";
+           $cont = "\cK";
+       } else {
+           $cont = $cuddle . "continue {\n\t" .
+             $self->deparse($cont, 0) . "\n\b}\cK";
        }
-    }
-    if ($precont and $ {$precont->next} == $ {$enter->nextop}
-       || $ {$precont->next} == $ {$enter->nextop->next} )
-    {
-       my $state = $kid->first;
-       my $cuddle = $self->{'cuddle'};
-       my($expr, @exprs);
-       for (; $$state != $$cont; $state = $state->sibling) {
-          $expr = "";
-          if (is_state $state) {
-              $expr = $self->deparse($state, 0);
-              $state = $state->sibling;
-              last if null $state;
-          }
-          $expr .= $self->deparse($state, 0);
-          push @exprs, $expr if $expr;
-       }
-       $kid = join(";\n", @exprs);
-       $cont = $cuddle . "continue {\n\t" .
-        $self->deparse($cont, 0) . "\n\b}\cK";
     } else {
        $cont = "\cK";
-       $kid = $self->deparse($kid, 0);
+       $body = $self->deparse($body, 0);
     }
-    return $head . "{\n\t" . $kid . "\n\b}" . $cont;
+    return $head . "{\n\t" . $body . "\n\b}" . $cont;
+}
+
+sub pp_leaveloop { loop_common(@_, "") }
+
+sub for_loop {
+    my $self = shift;
+    my($op, $cx) = @_;
+    my $init = $self->deparse($op, 1);
+    return $self->loop_common($op->sibling, $cx, $init);
 }
 
 sub pp_leavetry {
@@ -2851,8 +2864,8 @@ B::Deparse - Perl compiler backend to produce perl code
 
 =head1 SYNOPSIS
 
-B<perl> B<-MO=Deparse>[B<,-u>I<PACKAGE>][B<,-p>][B<,-q>][B<,-l>][B<,-s>I<LETTERS>]
-     I<prog.pl>
+B<perl> B<-MO=Deparse>[B<,-u>I<PACKAGE>][B<,-p>][B<,-q>][B<,-l>]
+        [B<,-s>I<LETTERS>][B<,-x>I<LEVEL>] I<prog.pl>
 
 =head1 DESCRIPTION
 
@@ -2997,6 +3010,55 @@ file is compiled as a main program.
 
 =back
 
+=item B<-x>I<LEVEL>
+
+Expand conventional syntax constructions into equivalent ones that expose
+their internal operation. I<LEVEL> should be a digit, with higher values
+meaning more expansion. As with B<-q>, this actually involves turning off
+special cases in B::Deparse's normal operations.
+
+If I<LEVEL> is at least 3, for loops will be translated into equivalent
+while loops with continue blocks; for instance
+
+    for ($i = 0; $i < 10; ++$i) {
+        print $i;
+    }
+
+turns into
+
+    $i = 0;
+    while ($i < 10) {
+        print $i;
+    } continue {
+        ++$i
+    }
+
+Note that in a few cases this translation can't be perfectly carried back
+into the source code -- if the loop's initializer declares a my variable,
+for instance, it won't have the correct scope outside of the loop.
+
+If I<LEVEL> is at least 7, if statements will be translated into equivalent
+expressions using C<&&>, C<?:> and C<do {}>; for instance
+
+    print 'hi' if $nice;
+    if ($nice) {
+        print 'hi';
+    }
+    if ($nice) {
+        print 'hi';
+    } else {
+        print 'bye';
+    }
+
+turns into
+
+    $nice and print 'hi';
+    $nice and do { print 'hi' };
+    $nice ? do { print 'hi' } : do { print 'bye' };
+
+Long sequences of elsifs will turn into nested ternary operators, which
+B::Deparse doesn't know how to indent nicely.
+
 =back
 
 =head1 USING B::Deparse AS A MODULE
@@ -3043,7 +3105,7 @@ See the 'to do' list at the beginning of the module file.
 
 =head1 AUTHOR
 
-Stephen McCamant <smccam@uclink4.berkeley.edu>, based on an earlier
+Stephen McCamant <smcc@CSUA.Berkeley.EDU>, based on an earlier
 version by Malcolm Beattie <mbeattie@sable.ox.ac.uk>, with
 contributions from Gisle Aas, James Duncan, Albert Dvornik, Hugo van
 der Sanden, Gurusamy Sarathy, and Nick Ing-Simmons.
index ed0d07d..094b3cf 100644 (file)
@@ -116,7 +116,7 @@ Malcolm Beattie, mbeattie@sable.ox.ac.uk.
 =cut
 
 use strict;
-use B qw(walkoptree_slow main_root walksymtable svref_2object parents
+use B qw(walkoptree main_root walksymtable svref_2object parents
          OPf_WANT_LIST OPf_WANT OPf_STACKED G_ARRAY
         );
 
@@ -277,12 +277,12 @@ sub B::GV::lintcv {
     return if !$$cv || $done_cv{$$cv}++;
     my $root = $cv->ROOT;
     #warn "    root = $root (0x$$root)\n";#debug
-    walkoptree_slow($root, "lint") if $$root;
+    walkoptree($root, "lint") if $$root;
 }
 
 sub do_lint {
     my %search_pack;
-    walkoptree_slow(main_root, "lint") if ${main_root()};
+    walkoptree(main_root, "lint") if ${main_root()};
     
     # Now do subs in main
     no strict qw(vars refs);
index 66b5cfc..a7a071e 100644 (file)
@@ -1,6 +1,6 @@
 package B::Terse;
 use strict;
-use B qw(peekop class walkoptree_slow walkoptree_exec
+use B qw(peekop class walkoptree walkoptree_exec walkoptree_slow
         main_start main_root cstring svref_2object);
 use B::Asmdata qw(@specialsv_name);
 
index e191ec7..63c24e1 100644 (file)
@@ -265,6 +265,7 @@ PPCODE:
 
     /* %INC must be clean for use/require in compartment */
     save_hash(PL_incgv);
+    sv_free((SV*)GvHV(PL_incgv));  /* get rid of what save_hash gave us*/
     GvHV(PL_incgv) = (HV*)SvREFCNT_inc(GvHV(gv_HVadd(gv_fetchpv("INC",TRUE,SVt_PVHV))));
 
     PUSHMARK(SP);
diff --git a/op.c b/op.c
index 3d2404c..1bc27b2 100644 (file)
--- a/op.c
+++ b/op.c
@@ -55,6 +55,7 @@ S_Slab_Alloc(pTHX_ int m, size_t sz)
      : CALL_FPTR(PL_check[type])(aTHX_ (OP*)o))
 
 #define PAD_MAX 999999999
+#define RETURN_UNLIMITED_NUMBER (PERL_INT_MAX / 2)
 
 STATIC char*
 S_gv_ename(pTHX_ GV *gv)
@@ -1350,6 +1351,31 @@ Perl_mod(pTHX_ OP *o, I32 type)
        PL_modcount++;
        return o;
     case OP_CONST:
+        if (o->op_private & (OPpCONST_BARE) && 
+                !(type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN)) {
+            SV *sv = ((SVOP*)o)->op_sv;
+            GV *gv;
+
+            /* Could be a filehandle */
+            if (gv = gv_fetchpv(SvPV_nolen(sv), FALSE, SVt_PVIO)) {
+                OP* gvio = newUNOP(OP_RV2GV, 0, newGVOP(OP_GV, 0, gv));
+                op_free(o);
+                o = gvio;
+            } else {
+                /* OK, it's a sub */
+                OP* enter;
+                gv = gv_fetchpv(SvPV_nolen(sv), TRUE, SVt_PVCV);
+
+                enter = newUNOP(OP_ENTERSUB,0, 
+                        newUNOP(OP_RV2CV, 0, 
+                            newGVOP(OP_GV, 0, gv)
+                        ));
+                enter->op_private |= OPpLVAL_INTRO;
+                op_free(o);
+                o = enter;
+            }
+            break;
+        }
        if (!(o->op_private & (OPpCONST_ARYBASE)))
            goto nomod;
        if (PL_eval_start && PL_eval_start->op_type == OP_CONST) {
@@ -1380,6 +1406,7 @@ Perl_mod(pTHX_ OP *o, I32 type)
        }
        else {                          /* lvalue subroutine call */
            o->op_private |= OPpLVAL_INTRO;
+           PL_modcount = RETURN_UNLIMITED_NUMBER;
            if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN) {
                /* Backward compatibility mode: */
                o->op_private |= OPpENTERSUB_INARGS;
@@ -1514,7 +1541,7 @@ Perl_mod(pTHX_ OP *o, I32 type)
        if (!type && cUNOPo->op_first->op_type != OP_GV)
            Perl_croak(aTHX_ "Can't localize through a reference");
        if (type == OP_REFGEN && o->op_flags & OPf_PARENS) {
-           PL_modcount = 10000;
+           PL_modcount = RETURN_UNLIMITED_NUMBER;
            return o;           /* Treat \(@foo) like ordinary list. */
        }
        /* FALL THROUGH */
@@ -1523,14 +1550,16 @@ Perl_mod(pTHX_ OP *o, I32 type)
            goto nomod;
        ref(cUNOPo->op_first, o->op_type);
        /* FALL THROUGH */
-    case OP_AASSIGN:
     case OP_ASLICE:
     case OP_HSLICE:
+       if (type == OP_LEAVESUBLV)
+           o->op_private |= OPpMAYBE_LVSUB;
+       /* FALL THROUGH */
+    case OP_AASSIGN:
     case OP_NEXTSTATE:
     case OP_DBSTATE:
-    case OP_REFGEN:
     case OP_CHOMP:
-       PL_modcount = 10000;
+       PL_modcount = RETURN_UNLIMITED_NUMBER;
        break;
     case OP_RV2SV:
        if (!type && cUNOPo->op_first->op_type != OP_GV)
@@ -1549,11 +1578,13 @@ Perl_mod(pTHX_ OP *o, I32 type)
 
     case OP_PADAV:
     case OP_PADHV:
-       PL_modcount = 10000;
+       PL_modcount = RETURN_UNLIMITED_NUMBER;
        if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
            return o;           /* Treat \(@foo) like ordinary list. */
        if (scalar_mod_type(o, type))
            goto nomod;
+       if (type == OP_LEAVESUBLV)
+           o->op_private |= OPpMAYBE_LVSUB;
        /* FALL THROUGH */
     case OP_PADSV:
        PL_modcount++;
@@ -1581,6 +1612,8 @@ Perl_mod(pTHX_ OP *o, I32 type)
        /* FALL THROUGH */
     case OP_POS:
     case OP_VEC:
+       if (type == OP_LEAVESUBLV)
+           o->op_private |= OPpMAYBE_LVSUB;
       lvalue_func:
        pad_free(o->op_targ);
        o->op_targ = pad_alloc(o->op_type, SVs_PADMY);
@@ -1595,12 +1628,15 @@ Perl_mod(pTHX_ OP *o, I32 type)
        if (type == OP_ENTERSUB &&
             !(o->op_private & (OPpLVAL_INTRO | OPpDEREF)))
            o->op_private |= OPpLVAL_DEFER;
+       if (type == OP_LEAVESUBLV)
+           o->op_private |= OPpMAYBE_LVSUB;
        PL_modcount++;
        break;
 
     case OP_SCOPE:
     case OP_LEAVE:
     case OP_ENTER:
+    case OP_LINESEQ:
        if (o->op_flags & OPf_KIDS)
            mod(cLISTOPo->op_last, type);
        break;
@@ -1619,8 +1655,14 @@ Perl_mod(pTHX_ OP *o, I32 type)
        for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
            mod(kid, type);
        break;
+
+    case OP_RETURN:
+       if (type != OP_LEAVESUBLV)
+           goto nomod;
+       break; /* mod()ing was handled by ck_return() */
     }
-    o->op_flags |= OPf_MOD;
+    if (type != OP_LEAVESUBLV)
+        o->op_flags |= OPf_MOD;
 
     if (type == OP_AASSIGN || type == OP_SASSIGN)
        o->op_flags |= OPf_SPECIAL|OPf_REF;
@@ -1629,7 +1671,8 @@ Perl_mod(pTHX_ OP *o, I32 type)
        o->op_flags &= ~OPf_SPECIAL;
        PL_hints |= HINT_BLOCK_SCOPE;
     }
-    else if (type != OP_GREPSTART && type != OP_ENTERSUB)
+    else if (type != OP_GREPSTART && type != OP_ENTERSUB
+             && type != OP_LEAVESUBLV)
        o->op_flags |= OPf_REF;
     return o;
 }
@@ -3462,7 +3505,7 @@ Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
                    }
                }
                else {
-                   if (PL_modcount < 10000 &&
+                   if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
                      ((LISTOP*)right)->op_last->op_type == OP_CONST)
                    {
                        SV *sv = ((SVOP*)((LISTOP*)right)->op_last)->op_sv;
@@ -3890,7 +3933,6 @@ Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32 whileline, OP *
 
     if (cont) {
        next = LINKLIST(cont);
-       loopflags |= OPpLOOP_CONTINUE;
     }
     if (expr) {
        OP *unstack = newOP(OP_UNSTACK, 0);
@@ -4581,7 +4623,8 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
        av_store(PL_comppad_name, AvFILLp(PL_comppad), Nullsv);
 
     if (CvLVALUE(cv)) {
-       CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0, scalarseq(block));
+       CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0,
+                            mod(scalarseq(block), OP_LEAVESUBLV));
     }
     else {
        CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block));
@@ -5365,6 +5408,7 @@ Perl_ck_rvconst(pTHX_ register OP *o)
 #else
            kid->op_sv = SvREFCNT_inc(gv);
 #endif
+           kid->op_private = 0;
            kid->op_ppaddr = PL_ppaddr[OP_GV];
        }
     }
@@ -5973,6 +6017,17 @@ Perl_ck_require(pTHX_ OP *o)
     return ck_fun(o);
 }
 
+OP *
+Perl_ck_return(pTHX_ OP *o)
+{
+    OP *kid;
+    if (CvLVALUE(PL_compcv)) {
+       for (kid = cLISTOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
+           mod(kid, OP_LEAVESUBLV);
+    }
+    return o;
+}
+
 #if 0
 OP *
 Perl_ck_retarget(pTHX_ OP *o)
@@ -6452,7 +6507,6 @@ Perl_peep(pTHX_ register OP *o)
 {
     register OP* oldop = 0;
     STRLEN n_a;
-    OP *last_composite = Nullop;
 
     if (!o || o->op_seq)
        return;
@@ -6471,7 +6525,6 @@ Perl_peep(pTHX_ register OP *o)
        case OP_DBSTATE:
            PL_curcop = ((COP*)o);              /* for warnings */
            o->op_seq = PL_op_seqmax++;
-           last_composite = Nullop;
            break;
 
        case OP_CONST:
@@ -6562,7 +6615,7 @@ Perl_peep(pTHX_ register OP *o)
                    (PL_op = pop->op_next) &&
                    pop->op_next->op_type == OP_AELEM &&
                    !(pop->op_next->op_private &
-                     (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF)) &&
+                     (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
                    (i = SvIV(((SVOP*)pop)->op_sv) - PL_compiling.cop_arybase)
                                <= 255 &&
                    i >= 0)
@@ -6611,8 +6664,14 @@ Perl_peep(pTHX_ register OP *o)
 
        case OP_ENTERLOOP:
            o->op_seq = PL_op_seqmax++;
+           while (cLOOP->op_redoop->op_type == OP_NULL)
+               cLOOP->op_redoop = cLOOP->op_redoop->op_next;
            peep(cLOOP->op_redoop);
+           while (cLOOP->op_nextop->op_type == OP_NULL)
+               cLOOP->op_nextop = cLOOP->op_nextop->op_next;
            peep(cLOOP->op_nextop);
+           while (cLOOP->op_lastop->op_type == OP_NULL)
+               cLOOP->op_lastop = cLOOP->op_lastop->op_next;
            peep(cLOOP->op_lastop);
            break;
 
@@ -6620,6 +6679,9 @@ Perl_peep(pTHX_ register OP *o)
        case OP_MATCH:
        case OP_SUBST:
            o->op_seq = PL_op_seqmax++;
+           while (cPMOP->op_pmreplstart && 
+                  cPMOP->op_pmreplstart->op_type == OP_NULL)
+               cPMOP->op_pmreplstart = cPMOP->op_pmreplstart->op_next;
            peep(cPMOP->op_pmreplstart);
            break;
 
@@ -6752,42 +6814,6 @@ Perl_peep(pTHX_ register OP *o)
            break;
        }
 
-       case OP_RV2AV:
-       case OP_RV2HV:
-           if (!(o->op_flags & OPf_WANT)
-               || (o->op_flags & OPf_WANT) == OPf_WANT_LIST)
-           {
-               last_composite = o;
-           }
-           o->op_seq = PL_op_seqmax++;
-           break;
-
-       case OP_RETURN:
-           if (o->op_next && o->op_next->op_type != OP_LEAVESUBLV) {
-               o->op_seq = PL_op_seqmax++;
-               break;
-           }
-           /* FALL THROUGH */
-
-       case OP_LEAVESUBLV:
-           if (last_composite) {
-               OP *r = last_composite;
-
-               while (r->op_sibling)
-                  r = r->op_sibling;
-               if (r->op_next == o 
-                   || (r->op_next->op_type == OP_LIST
-                       && r->op_next->op_next == o))
-               {
-                   if (last_composite->op_type == OP_RV2AV)
-                       yyerror("Lvalue subs returning arrays not implemented yet");
-                   else
-                       yyerror("Lvalue subs returning hashes not implemented yet");
-                       ;
-               }               
-           }
-           /* FALL THROUGH */
-
        default:
            o->op_seq = PL_op_seqmax++;
            break;
diff --git a/op.h b/op.h
index 55b85a5..97b057a 100644 (file)
--- a/op.h
+++ b/op.h
@@ -139,9 +139,6 @@ Deprecated.  Use C<GIMME_V> instead.
 /* Private for OP_REPEAT */
 #define OPpREPEAT_DOLIST       64      /* List replication. */
 
-/* Private for OP_LEAVELOOP */
-#define OPpLOOP_CONTINUE       64      /* a continue block is present */
-
 /* Private for OP_RV2?V, OP_?ELEM */
 #define OPpDEREF               (32|64) /* Want ref to something: */
 #define OPpDEREF_AV            32      /*   Want ref to AV. */
@@ -159,7 +156,9 @@ Deprecated.  Use C<GIMME_V> instead.
   /* OP_?ELEM only */
 #define OPpLVAL_DEFER          16      /* Defer creation of array/hash elem */
   /* OP_RV2?V, OP_GVSV only */
-#define OPpOUR_INTRO           16      /* Defer creation of array/hash elem */
+#define OPpOUR_INTRO           16      /* Variable was in an our() */
+  /* OP_RV2[AH]V, OP_PAD[AH]V, OP_[AH]ELEM */
+#define OPpMAYBE_LVSUB         8       /* We might be an lvalue to return */
   /* for OP_RV2?V, lower bits carry hints (currently only HINT_STRICT_REFS) */
 
 /* Private for OPs with TARGLEX */
index 8dc8b7a..542ec60 100644 (file)
--- a/opcode.h
+++ b/opcode.h
@@ -541,7 +541,7 @@ EXT char *PL_op_desc[] = {
        "method lookup",
        "subroutine entry",
        "subroutine exit",
-       "lvalue subroutine exit",
+       "lvalue subroutine return",
        "caller",
        "warn",
        "die",
@@ -1278,7 +1278,7 @@ EXT OP * (CPERLscope(*PL_check)[]) (pTHX_ OP *op) = {
        MEMBER_TO_FPTR(Perl_ck_null),   /* iter */
        MEMBER_TO_FPTR(Perl_ck_null),   /* enterloop */
        MEMBER_TO_FPTR(Perl_ck_null),   /* leaveloop */
-       MEMBER_TO_FPTR(Perl_ck_null),   /* return */
+       MEMBER_TO_FPTR(Perl_ck_return), /* return */
        MEMBER_TO_FPTR(Perl_ck_null),   /* last */
        MEMBER_TO_FPTR(Perl_ck_null),   /* next */
        MEMBER_TO_FPTR(Perl_ck_null),   /* redo */
index 43d98ae..beca4a1 100755 (executable)
--- a/opcode.pl
+++ b/opcode.pl
@@ -596,7 +596,7 @@ orassign    logical or assignment (||=)     ck_null         s|
 method         method lookup           ck_method       d1
 entersub       subroutine entry        ck_subr         dmt1    L
 leavesub       subroutine exit         ck_null         1       
-leavesublv     lvalue subroutine exit  ck_null         1       
+leavesublv     lvalue subroutine return        ck_null         1       
 caller         caller                  ck_fun          t%      S?
 warn           warn                    ck_fun          imst@   L
 die            die                     ck_fun          dimst@  L
@@ -613,7 +613,7 @@ enteriter   foreach loop entry      ck_null         d{
 iter           foreach loop iterator   ck_null         0       
 enterloop      loop entry              ck_null         d{      
 leaveloop      loop exit               ck_null         2       
-return         return                  ck_null         dm@     L
+return         return                  ck_return       dm@     L
 last           last                    ck_null         ds}     
 next           next                    ck_null         ds}     
 redo           redo                    ck_null         ds}     
index b680687..5ea1083 100644 (file)
@@ -899,6 +899,14 @@ suidperl.
 temporary or readonly values) from a subroutine used as an lvalue.  This
 is not allowed.
 
+=item Can't return %s to lvalue scalar context
+
+(F) You tried to return a complete array or hash from an lvalue subroutine,
+but you called the subroutine in a way that made Perl think you meant
+to return only one value. You probably meant to write parentheses around
+the call to the subroutine, which tell Perl that the call should be in
+list context.
+
 =item Can't return outside a subroutine
 
 (F) The return statement was executed in mainline code, that is, where
index cef8050..b440cd1 100644 (file)
@@ -645,10 +645,6 @@ and in:
 
 all the subroutines are called in a list context.
 
-The current implementation does not allow arrays and hashes to be
-returned from lvalue subroutines directly.  You may return a
-reference instead.  This restriction may be lifted in future.
-
 =head2 Passing Symbol Table Entries (typeglobs)
 
 B<WARNING>: The mechanism described in this section was originally
diff --git a/pp.c b/pp.c
index a8bdb61..3df975d 100644 (file)
--- a/pp.c
+++ b/pp.c
@@ -114,6 +114,11 @@ PP(pp_padav)
     if (PL_op->op_flags & OPf_REF) {
        PUSHs(TARG);
        RETURN;
+    } else if (LVRET) {
+       if (GIMME == G_SCALAR)
+           Perl_croak(aTHX_ "Can't return array to lvalue scalar context");
+       PUSHs(TARG);
+       RETURN;
     }
     if (GIMME == G_ARRAY) {
        I32 maxarg = AvFILL((AV*)TARG) + 1;
@@ -149,6 +154,11 @@ PP(pp_padhv)
        SAVECLEARSV(PL_curpad[PL_op->op_targ]);
     if (PL_op->op_flags & OPf_REF)
        RETURN;
+    else if (LVRET) {
+       if (GIMME == G_SCALAR)
+           Perl_croak(aTHX_ "Can't return hash to lvalue scalar context");
+       RETURN;
+    }
     gimme = GIMME_V;
     if (gimme == G_ARRAY) {
        RETURNOP(do_kv());
@@ -340,7 +350,7 @@ PP(pp_pos)
 {
     djSP; dTARGET; dPOPss;
 
-    if (PL_op->op_flags & OPf_MOD) {
+    if (PL_op->op_flags & OPf_MOD || LVRET) {
        if (SvTYPE(TARG) < SVt_PVLV) {
            sv_upgrade(TARG, SVt_PVLV);
            sv_magic(TARG, Nullsv, '.', Nullch, 0);
@@ -384,8 +394,12 @@ PP(pp_rv2cv)
     if (cv) {
        if (CvCLONE(cv))
            cv = (CV*)sv_2mortal((SV*)cv_clone(cv));
-       if ((PL_op->op_private & OPpLVAL_INTRO) && !CvLVALUE(cv))
-           DIE(aTHX_ "Can't modify non-lvalue subroutine call");
+       if ((PL_op->op_private & OPpLVAL_INTRO)) {
+           if (gv && GvCV(gv) == cv && (gv = gv_autoload4(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv), FALSE)))
+               cv = GvCV(gv);
+           if (!CvLVALUE(cv))
+               DIE(aTHX_ "Can't modify non-lvalue subroutine call");
+       }
     }
     else
        cv = (CV*)&PL_sv_undef;
@@ -2009,16 +2023,17 @@ PP(pp_substr)
     I32 pos;
     I32 rem;
     I32 fail;
-    I32 lvalue = PL_op->op_flags & OPf_MOD;
+    I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
     char *tmps;
     I32 arybase = PL_curcop->cop_arybase;
     char *repl = 0;
     STRLEN repl_len;
+    int num_args = PL_op->op_private & 7;
 
     SvTAINTED_off(TARG);                       /* decontaminate */
     SvUTF8_off(TARG);                          /* decontaminate */
-    if (MAXARG > 2) {
-       if (MAXARG > 3) {
+    if (num_args > 2) {
+       if (num_args > 3) {
            sv = POPs;
            repl = SvPV(sv, repl_len);
        }
@@ -2042,7 +2057,7 @@ PP(pp_substr)
        pos -= arybase;
        rem = curlen-pos;
        fail = rem;
-       if (MAXARG > 2) {
+       if (num_args > 2) {
            if (len < 0) {
                rem += len;
                if (rem < 0)
@@ -2054,7 +2069,7 @@ PP(pp_substr)
     }
     else {
        pos += curlen;
-       if (MAXARG < 3)
+       if (num_args < 3)
            rem = curlen;
        else if (len >= 0) {
            rem = pos+len;
@@ -2130,7 +2145,7 @@ PP(pp_vec)
     register IV size   = POPi;
     register IV offset = POPi;
     register SV *src = POPs;
-    I32 lvalue = PL_op->op_flags & OPf_MOD;
+    I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
 
     SvTAINTED_off(TARG);               /* decontaminate */
     if (lvalue) {                      /* it's an lvalue! */
@@ -2625,7 +2640,7 @@ PP(pp_aslice)
     djSP; dMARK; dORIGMARK;
     register SV** svp;
     register AV* av = (AV*)POPs;
-    register I32 lval = PL_op->op_flags & OPf_MOD;
+    register I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
     I32 arybase = PL_curcop->cop_arybase;
     I32 elem;
 
@@ -2812,7 +2827,7 @@ PP(pp_hslice)
 {
     djSP; dMARK; dORIGMARK;
     register HV *hv = (HV*)POPs;
-    register I32 lval = PL_op->op_flags & OPf_MOD;
+    register I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
     I32 realhv = (SvTYPE(hv) == SVt_PVHV);
 
     if (!realhv && PL_op->op_private & OPpLVAL_INTRO)
diff --git a/pp.h b/pp.h
index 2226c20..0ab91cd 100644 (file)
--- a/pp.h
+++ b/pp.h
@@ -373,3 +373,10 @@ See C<PUSHu>.
     SvREFCNT_dec(tmpRef);                   \
     SvRV(rv)=AMG_CALLun(rv,copy);        \
   } } STMT_END
+
+/*
+=for apidoc mU||LVRET
+True if this op will be the return value of an lvalue subroutine
+
+=cut */
+#define LVRET ((PL_op->op_private & OPpMAYBE_LVSUB) && is_lvalue_sub())
diff --git a/pp.sym b/pp.sym
index 42b29f6..2bd3922 100644 (file)
--- a/pp.sym
+++ b/pp.sym
@@ -30,6 +30,7 @@ Perl_ck_null
 Perl_ck_open
 Perl_ck_repeat
 Perl_ck_require
+Perl_ck_return
 Perl_ck_rfun
 Perl_ck_rvconst
 Perl_ck_sassign
index a76a241..06d16e7 100644 (file)
--- a/pp_ctl.c
+++ b/pp_ctl.c
@@ -1197,6 +1197,20 @@ Perl_block_gimme(pTHX)
     }
 }
 
+I32
+Perl_is_lvalue_sub(pTHX)
+{
+    I32 cxix;
+
+    cxix = dopoptosub(cxstack_ix);
+    assert(cxix >= 0);  /* We should only be called from inside subs */
+
+    if (cxstack[cxix].blk_sub.lval && CvLVALUE(cxstack[cxix].blk_sub.cv))
+       return cxstack[cxix].blk_sub.lval;
+    else
+       return 0;
+}
+
 STATIC I32
 S_dopoptosub(pTHX_ I32 startingblock)
 {
index bfd06dd..de15c95 100644 (file)
--- a/pp_hot.c
+++ b/pp_hot.c
@@ -447,6 +447,12 @@ PP(pp_rv2av)
            SETs((SV*)av);
            RETURN;
        }
+       else if (LVRET) {
+           if (GIMME == G_SCALAR)
+               Perl_croak(aTHX_ "Can't return array to lvalue scalar context");
+           SETs((SV*)av);
+           RETURN;
+       }
     }
     else {
        if (SvTYPE(sv) == SVt_PVAV) {
@@ -455,6 +461,13 @@ PP(pp_rv2av)
                SETs((SV*)av);
                RETURN;
            }
+           else if (LVRET) {
+               if (GIMME == G_SCALAR)
+                   Perl_croak(aTHX_ "Can't return array to lvalue"
+                              " scalar context");
+               SETs((SV*)av);
+               RETURN;
+           }
        }
        else {
            GV *gv;
@@ -508,6 +521,13 @@ PP(pp_rv2av)
                SETs((SV*)av);
                RETURN;
            }
+           else if (LVRET) {
+               if (GIMME == G_SCALAR)
+                   Perl_croak(aTHX_ "Can't return array to lvalue"
+                              " scalar context");
+               SETs((SV*)av);
+               RETURN;
+           }
        }
     }
 
@@ -551,6 +571,12 @@ PP(pp_rv2hv)
            SETs((SV*)hv);
            RETURN;
        }
+       else if (LVRET) {
+           if (GIMME == G_SCALAR)
+               Perl_croak(aTHX_ "Can't return hash to lvalue scalar context");
+           SETs((SV*)hv);
+           RETURN;
+       }
     }
     else {
        if (SvTYPE(sv) == SVt_PVHV || SvTYPE(sv) == SVt_PVAV) {
@@ -559,6 +585,13 @@ PP(pp_rv2hv)
                SETs((SV*)hv);
                RETURN;
            }
+           else if (LVRET) {
+               if (GIMME == G_SCALAR)
+                   Perl_croak(aTHX_ "Can't return hash to lvalue"
+                              " scalar context");
+               SETs((SV*)hv);
+               RETURN;
+           }
        }
        else {
            GV *gv;
@@ -612,6 +645,13 @@ PP(pp_rv2hv)
                SETs((SV*)hv);
                RETURN;
            }
+           else if (LVRET) {
+               if (GIMME == G_SCALAR)
+                   Perl_croak(aTHX_ "Can't return hash to lvalue"
+                              " scalar context");
+               SETs((SV*)hv);
+               RETURN;
+           }
        }
     }
 
@@ -1507,7 +1547,7 @@ PP(pp_helem)
     SV **svp;
     SV *keysv = POPs;
     HV *hv = (HV*)POPs;
-    U32 lval = PL_op->op_flags & OPf_MOD;
+    U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
     U32 defer = PL_op->op_private & OPpLVAL_DEFER;
     SV *sv;
 
@@ -2745,7 +2785,7 @@ PP(pp_aelem)
     SV** svp;
     IV elem = POPi;
     AV* av = (AV*)POPs;
-    U32 lval = PL_op->op_flags & OPf_MOD;
+    U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
     U32 defer = (PL_op->op_private & OPpLVAL_DEFER) && (elem > AvFILL(av));
     SV *sv;
 
index c249ecb..c3b24e8 100644 (file)
@@ -29,6 +29,7 @@ PERL_CKDEF(Perl_ck_null)
 PERL_CKDEF(Perl_ck_open)
 PERL_CKDEF(Perl_ck_repeat)
 PERL_CKDEF(Perl_ck_require)
+PERL_CKDEF(Perl_ck_return)
 PERL_CKDEF(Perl_ck_rfun)
 PERL_CKDEF(Perl_ck_rvconst)
 PERL_CKDEF(Perl_ck_sassign)
diff --git a/proto.h b/proto.h
index c8914eb..8710ec3 100644 (file)
--- a/proto.h
+++ b/proto.h
@@ -331,6 +331,7 @@ PERL_CALLCONV char* Perl_instr(pTHX_ const char* big, const char* little);
 PERL_CALLCONV bool     Perl_io_close(pTHX_ IO* io, bool not_implicit);
 PERL_CALLCONV OP*      Perl_invert(pTHX_ OP* cmd);
 PERL_CALLCONV bool     Perl_is_gv_magical(pTHX_ char *name, STRLEN len, U32 flags);
+PERL_CALLCONV I32      Perl_is_lvalue_sub(pTHX);
 PERL_CALLCONV bool     Perl_is_uni_alnum(pTHX_ U32 c);
 PERL_CALLCONV bool     Perl_is_uni_alnumc(pTHX_ U32 c);
 PERL_CALLCONV bool     Perl_is_uni_idfirst(pTHX_ U32 c);
index 3871e0b..7c04a29 100755 (executable)
@@ -16,10 +16,8 @@ BEGIN {
     }
 }
 
-
-use FileHandle;
 use Config;
-autoflush STDOUT 1;
+$| = 1;
 $SIG{PIPE} = 'IGNORE';
 
 print "1..10\n";
@@ -33,10 +31,8 @@ $perl = qq[$^X "-I../lib"];
 # the other reader reads one line, waits a few seconds and then
 # exits to test the waitpid function.
 #
-$cmd1 = qq/$perl -e "use FileHandle; autoflush STDOUT 1; / .
-        qq/print qq[first process\\n]; sleep 30;"/;
-$cmd2 = qq/$perl -e "use FileHandle; autoflush STDOUT 1; / .
-        qq/print qq[second process\\n]; sleep 30;"/;
+$cmd1 = qq/$perl -e "\$|=1; print qq[first process\\n]; sleep 30;"/;
+$cmd2 = qq/$perl -e "\$|=1; print qq[second process\\n]; sleep 30;"/;
 $cmd3 = qq/$perl -e "print <>;"/; # hangs waiting for end of STDIN
 $cmd4 = qq/$perl -e "print scalar <>;"/;
 
@@ -76,7 +72,8 @@ print "not " unless $kill_cnt == 2;
 print "ok 8\n";
 
 # send one expected line of text to child process and then wait for it
-autoflush FH4 1;
+select(FH4); $| = 1; select(STDOUT);
+
 print FH4 "ok 9\n";
 print "# waiting for process $pid4 to exit\n";
 $reap_pid = waitpid $pid4, 0;
index 2be4d10..f119ae1 100755 (executable)
--- a/t/lib/b.t
+++ b/t/lib/b.t
@@ -10,7 +10,7 @@ use warnings;
 use strict;
 use Config;
 
-print "1..13\n";
+print "1..15\n";
 
 my $test = 1;
 
@@ -34,21 +34,21 @@ ok;
 my $a = <<'EOF';
 {
     $test = sub : lvalue {
-        1;
+        my $x;
     }
     ;
 }
 EOF
 chomp $a;
-print "not " if $deparse->coderef2text(sub{$test = sub : lvalue { 1 }}) ne $a;
+print "not " if $deparse->coderef2text(sub{$test = sub : lvalue{my $x}}) ne $a;
 ok;
 
 $a =~ s/lvalue/method/;
-print "not " if $deparse->coderef2text(sub{$test = sub : method { 1 }}) ne $a;
+print "not " if $deparse->coderef2text(sub{$test = sub : method{my $x}}) ne $a;
 ok;
 
 $a =~ s/method/locked method/;
-print "not " if $deparse->coderef2text(sub{$test = sub : method locked { 1 }})
+print "not " if $deparse->coderef2text(sub{$test = sub : method locked {my $x}})
                                      ne $a;
 ok;
 }
@@ -62,10 +62,7 @@ $b = <<'EOF';
 LINE: while (defined($_ = <ARGV>)) {
     chomp $_;
     @F = split(/\s+/, $_, 0);
-    '???'
-}
-continue {
-    '???'
+    '???';
 }
 
 EOF
@@ -81,7 +78,7 @@ ok;
 #7
 $a = `$^X "-I../lib" "-MO=Terse" -e 1 2>&1`;
 print "not " unless $a =~
-/\bLISTOP\b.*leave.*\bOP\b.*enter.*\bCOP\b.*nextstate.*\bOP\b.*null/s;
+/\bLISTOP\b.*leave.*\n    OP\b.*enter.*\n    COP\b.*nextstate.*\n    OP\b.*null/s;
 ok;
 
 $a = `$^X "-I../lib" "-MO=Terse" -ane "s/foo/bar/" 2>&1`;
@@ -119,7 +116,7 @@ $a =~ s/-u(Cwd|File|File::Copy|OS2),//g if $^O eq 'os2';
 $a =~ s/-uCwd,// if $^O eq 'cygwin';
 if ($Config{static_ext} eq ' ') {
   $b = '-uCarp,-uCarp::Heavy,-uDB,-uExporter,-uExporter::Heavy,-uattributes,'
-     . '-umain,-uwarnings';
+     . '-umain,-ustrict,-uwarnings';
   print "# [$a] vs [$b]\nnot " if $a ne $b;
   ok;
 } else {
@@ -133,3 +130,14 @@ if ($is_thread) {
     print "# [$a]\nnot " unless $a =~ /sv_undef.*PVNV.*%one.*sv_undef.*HV/s;
 }
 ok;
+
+# Bug 20001204.07
+{
+my $foo = $deparse->coderef2text(sub { { 234; }});
+# Constants don't get optimised here.
+print "not " unless $foo =~ /{.*{.*234;.*}.*}/sm;
+ok;
+$foo = $deparse->coderef2text(sub { { 234; } continue { 123; } });
+print "not " unless $foo =~ /{.*{.*234;.*}.*continue.*{.*123.*}/sm; 
+ok;
+}
index 3ab8766..03a2fa0 100755 (executable)
@@ -1,12 +1,12 @@
-print "1..46\n";
+print "1..64\n";
 
 BEGIN {
     chdir 't' if -d 't';
     @INC = '../lib';
 }
 
-sub a : lvalue { my $a = 34; bless \$a }  # Return a temporary
-sub b : lvalue { shift }
+sub a : lvalue { my $a = 34; ${\(bless \$a)} }  # Return a temporary
+sub b : lvalue { ${\shift} }
 
 my $out = a(b());              # Check that temporaries are allowed.
 print "# `$out'\nnot " unless ref $out eq 'main'; # Not reached if error.
@@ -34,9 +34,9 @@ print "ok 3\n";
 
 sub get_lex : lvalue { $in }
 sub get_st : lvalue { $blah }
-sub id : lvalue { shift }
+sub id : lvalue { ${\shift} }
 sub id1 : lvalue { $_[0] }
-sub inc : lvalue { ++$_[0] }
+sub inc : lvalue { ${\++$_[0]} }
 
 $in = 5;
 $blah = 3;
@@ -288,40 +288,41 @@ print "# '$_'.\nnot "
 print "ok 34\n";
 
 $x = '1234567';
-sub lv1t : lvalue { index $x, 2 }
 
 $_ = undef;
 eval <<'EOE' or $_ = $@;
+  sub lv1t : lvalue { index $x, 2 }
   lv1t = (2,3);
   1;
 EOE
 
 print "# '$_'.\nnot "
-  unless /Can\'t return a temporary from lvalue subroutine/;
+  unless /Can\'t modify index in lvalue subroutine return/;
 print "ok 35\n";
 
 $_ = undef;
 eval <<'EOE' or $_ = $@;
-  (lv1t) = (2,3);
+  sub lv2t : lvalue { shift }
+  (lv2t) = (2,3);
   1;
 EOE
 
 print "# '$_'.\nnot "
-  unless /Can\'t return a temporary from lvalue subroutine/;
+  unless /Can\'t modify shift in lvalue subroutine return/;
 print "ok 36\n";
 
 $xxx = 'xxx';
 sub xxx () { $xxx }  # Not lvalue
-sub lv1tmp : lvalue { xxx }                    # is it a TEMP?
 
 $_ = undef;
 eval <<'EOE' or $_ = $@;
+  sub lv1tmp : lvalue { xxx }                  # is it a TEMP?
   lv1tmp = (2,3);
   1;
 EOE
 
 print "# '$_'.\nnot "
-  unless /Can\'t return a temporary from lvalue subroutine/;
+  unless /Can\'t modify non-lvalue subroutine call in lvalue subroutine return/;
 print "ok 37\n";
 
 $_ = undef;
@@ -334,17 +335,17 @@ print "# '$_'.\nnot "
   unless /Can\'t return a temporary from lvalue subroutine/;
 print "ok 38\n";
 
-sub xxx () { 'xxx' } # Not lvalue
-sub lv1tmpr : lvalue { xxx }                   # is it a TEMP?
+sub yyy () { 'yyy' } # Const, not lvalue
 
 $_ = undef;
 eval <<'EOE' or $_ = $@;
+  sub lv1tmpr : lvalue { yyy }                 # is it read-only?
   lv1tmpr = (2,3);
   1;
 EOE
 
 print "# '$_'.\nnot "
-  unless /Can\'t return a readonly value from lvalue subroutine/;
+  unless /Can\'t modify constant item in lvalue subroutine return/;
 print "ok 39\n";
 
 $_ = undef;
@@ -357,8 +358,6 @@ print "# '$_'.\nnot "
   unless /Can\'t return a readonly value from lvalue subroutine/;
 print "ok 40\n";
 
-=for disabled constructs
-
 sub lva : lvalue {@a}
 
 $_ = undef;
@@ -369,8 +368,7 @@ eval <<'EOE' or $_ = $@;
   1;
 EOE
 
-print "# '$_'.\nnot "
-  unless /Can\'t return an uninitialized value from lvalue subroutine/;
+print "# '$_'.\nnot " unless "'@a' $_" eq "'2 3' ";
 print "ok 41\n";
 
 $_ = undef;
@@ -397,10 +395,6 @@ EOE
 print "# '$_'.\nnot " unless "'@a' $_" eq "'2 3' ";
 print "ok 43\n";
 
-=cut
-
-print "ok $_\n" for 41..43;
-
 sub lv1n : lvalue { $newvar }
 
 $_ = undef;
@@ -427,3 +421,117 @@ $a = \&lv1nn;
 $a->() = 8;
 print "# '$nnewvar'.\nnot " unless $nnewvar eq '8';
 print "ok 46\n";
+
+# This must happen at run time
+eval {
+    sub AUTOLOAD : lvalue { $newvar };
+};
+foobar() = 12;
+print "# '$newvar'.\nnot " unless $newvar eq "12";
+print "ok 47\n";
+
+# Testing DWIM of foo = bar;
+sub foo : lvalue {
+    $a;
+}
+$a = "not ok 48\n";
+foo = "ok 48\n";
+print $a;
+
+open bar, ">nothing" or die $!; 
+bar = *STDOUT;
+print bar "ok 49\n";
+unlink "nothing";
+
+{
+my %hash; my @array;
+sub alv : lvalue { $array[1] }
+sub alv2 : lvalue { $array[$_[0]] }
+sub hlv : lvalue { $hash{"foo"} }
+sub hlv2 : lvalue { $hash{$_[0]} }
+$array[1] = "not ok 51\n";
+alv() = "ok 50\n";
+print alv();
+
+alv2(20) = "ok 51\n";
+print $array[20];
+
+$hash{"foo"} = "not ok 52\n";
+hlv() = "ok 52\n";
+print $hash{foo};
+
+$hash{bar} = "not ok 53\n";
+hlv("bar") = "ok 53\n";
+print hlv("bar");
+
+sub array : lvalue  { @array  }
+sub array2 : lvalue { @array2 } # This is a global.
+sub hash : lvalue   { %hash   }
+sub hash2 : lvalue  { %hash2  } # So's this.
+@array2 = qw(foo bar);
+%hash2 = qw(foo bar);
+
+(array()) = qw(ok 54);
+print "not " unless "@array" eq "ok 54";
+print "ok 54\n";
+
+(array2()) = qw(ok 55);
+print "not " unless "@array2" eq "ok 55";
+print "ok 55\n";
+
+(hash()) = qw(ok 56);
+print "not " unless $hash{ok} == 56;
+print "ok 56\n";
+
+(hash2()) = qw(ok 57);
+print "not " unless $hash2{ok} == 57;
+print "ok 57\n";
+
+@array = qw(a b c d);
+sub aslice1 : lvalue { @array[0,2] };
+(aslice1()) = ("ok", "already");
+print "# @array\nnot " unless "@array" eq "ok b already d";
+print "ok 58\n";
+
+@array2 = qw(a B c d);
+sub aslice2 : lvalue { @array2[0,2] };
+(aslice2()) = ("ok", "already");
+print "not " unless "@array2" eq "ok B already d";
+print "ok 59\n";
+
+%hash = qw(a Alpha b Beta c Gamma);
+sub hslice : lvalue { @hash{"c", "b"} }
+(hslice()) = ("CISC", "BogoMIPS");
+print "not " unless join("/",@hash{"c","a","b"}) eq "CISC/Alpha/BogoMIPS";
+print "ok 60\n";
+}
+
+$str = "Hello, world!";
+sub sstr : lvalue { substr($str, 1, 4) }
+sstr() = "i";
+print "not " unless $str eq "Hi, world!";
+print "ok 61\n";
+
+$str = "Made w/ JavaScript";
+sub veclv : lvalue { vec($str, 2, 32) }
+veclv() = 0x5065726C;
+print "# $str\nnot " unless $str eq "Made w/ PerlScript";
+print "ok 62\n";
+
+sub position : lvalue { pos }
+@p = ();
+$_ = "fee fi fo fum";
+while (/f/g) {
+    push @p, position;
+    position() += 6;
+}
+print "# @p\nnot " unless "@p" eq "1 8";
+print "ok 63\n";
+
+# Bug 20001223.002: split thought that the list had only one element
+@ary = qw(4 5 6);
+sub lval1 : lvalue { $ary[0]; }
+sub lval2 : lvalue { $ary[1]; }
+(lval1(), lval2()) = split ' ', "1 2 3 4";
+print "not " unless join(':', @ary) eq "1:2:6";
+print "ok 64\n";
diff --git a/toke.c b/toke.c
index 7d04588..d47c418 100644 (file)
--- a/toke.c
+++ b/toke.c
@@ -3018,9 +3018,21 @@ Perl_yylex(pTHX)
                    PL_lex_stuff = Nullsv;
                }
                else {
-                   attrs = append_elem(OP_LIST, attrs,
-                                       newSVOP(OP_CONST, 0,
-                                               newSVpvn(s, len)));
+                   if (!PL_in_my && len == 6 && strnEQ(s, "lvalue", len))
+                       CvLVALUE_on(PL_compcv);
+                   else if (!PL_in_my && len == 6 && strnEQ(s, "locked", len))
+                       CvLOCKED_on(PL_compcv);
+                   else if (!PL_in_my && len == 6 && strnEQ(s, "method", len))
+                       CvMETHOD_on(PL_compcv);
+                   /* After we've set the flags, it could be argued that
+                      we don't need to do the attributes.pm-based setting
+                      process, and shouldn't bother appending recognized
+                      flags. To experiment with that, uncomment the
+                      following "else": */
+                   /* else */
+                       attrs = append_elem(OP_LIST, attrs,
+                                           newSVOP(OP_CONST, 0,
+                                                   newSVpvn(s, len)));
                }
                s = skipspace(d);
                if (*s == ':' && s[1] != ':')