cd build
mkdir perl-current
cd perl-current
rsync -avz rsync://ftp.linux.activestate.com/perl-current/ .
####
sh Configure -Doptimize='-g' -Dusethreads -Dusedevel -Dprefix=/local/perl
-ders && make
####
perl -e 'my *x'
####
syntax error at -e line 1, near "my *x"
####
/* "my" declarations, with optional attributes */
myattrterm: MY myterm myattrlist
{ $$ = my_attrs($2,$3); }
| MY myterm
{ $$ = localize($2,$1); }
;
/* Things that can be "my"'d */
myterm : '(' expr ')'
{ $$ = sawparens($2); }
| '(' ')'
{ $$ = sawparens(newNULLLIST()); }
| scalar %prec '('
{ $$ = $1; }
| hsh %prec '('
{ $$ = $1; }
| ary %prec '('
{ $$ = $1; }
;
####
scalar : '$' indirob
{ $$ = newSVREF($2); }
;
ary : '@' indirob
{ $$ = newAVREF($2); }
;
hsh : '%' indirob
{ $$ = newHVREF($2); }
;
####
star : '*' indirob
{ $$ = newGVREF(0,$2); }
;
####
| star %prec '('
{ $$ = $1; }
####
perl regen_perly.pl
make perl
####
$ ./perl -e 'my *x'
Can't declare ref-to-glob cast in "my" at -e line 1, at EOF
####
$ ./perl -MO=Concise -e 'my $x; my @y; my %z'
8 <@> leave[1 ref] vKP/REFC ->(end)
1 <0> enter ->2
2 <;> nextstate(main 1 -e:1) v ->3
3 <0> padsv[$x:1,4] vM/LVINTRO ->4
4 <;> nextstate(main 2 -e:1) v ->5
5 <0> padav[@y:2,4] vM/LVINTRO ->6
6 <;> nextstate(main 3 -e:1) v ->7
7 <0> padhv[%z:3,4] vM/LVINTRO ->8
-e syntax OK
####
$ diff -u opcode.pl{.orig,}
--- opcode.pl.orig 2005-10-18 19:07:24.000000000 +0100
+++ opcode.pl 2005-10-18 19:07:49.000000000 +0100
@@ -491,6 +491,7 @@
padsv private variable ck_null ds0
padav private array ck_null d0
padhv private hash ck_null d0
+padgv private glob ck_null d0
padany private value ck_null d0
pushre push regexp ck_null d/
####
--- op.c.before 2005-10-18 19:13:33.000000000 +0100
+++ op.c 2005-10-18 19:33:09.000000000 +0100
@@ -4902,7 +4902,13 @@
OP *
Perl_newGVREF(pTHX_ I32 type, OP *o)
{
- if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
+ dVAR;
+ if (o->op_type == OP_PADANY) {
+ o->op_type = OP_PADGV;
+ o->op_ppaddr = PL_ppaddr[OP_PADGV];
+ return o;
+ }
+ else if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
return newUNOP(OP_NULL, 0, o);
return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
}
####
--- pp.c.orig 2005-10-18 19:16:07.000000000 +0100
+++ pp.c 2005-10-18 19:17:51.000000000 +0100
@@ -127,6 +127,11 @@
RETURN;
}
+PP(pp_padgv)
+{
+ DIE(aTHX_ "OP_PADGV NOT YET IMPLEMENTED");
+}
+
PP(pp_padany)
{
DIE(aTHX_ "NOT IMPL LINE %d",__LINE__);
####
$ ./perl -MO=Concise -e 'my *x'
Can't declare ref-to-glob cast in "my" at -e line 1, at EOF
-e had compilation errors.
5 <@> leave[1 ref] KP/REFC ->(end)
1 <0> enter ->2
2 <;> nextstate(main 1 -e:1) ->3
4 <1> rv2gv sKR/1 ->5
3 <#> gv[*x] s ->4
####
$ gdb --args ./perl -e 'my *x'
...
(gdb) br Perl_newGVREF
Breakpoint 1 at 0x80a51e2: file op.c, line 4905.
(gdb) run
Starting program: /local/build/perl-current/perl -e my\ \*x
...
Breakpoint 1, Perl_newGVREF (my_perl=0x81b07c0, type=0, o=0x81ccc50)
at op.c:4905
4905 if (o->op_type == OP_PADANY) {
(gdb) p *o
$1 = {op_next = 0x81ccc50, op_sibling = 0x0,
op_ppaddr = 0x80e2c0c , op_targ = 0, op_type = 5, op_opt = 0,
op_static = 0, op_spare = 0, op_flags = 2 '\002', op_private = 16 '\020'}
####
$ grep OP_PADANY *.c
...
toke.c: yylval.opval = newOP(OP_PADANY, 0);
toke.c: yylval.opval = newOP(OP_PADANY, 0);
####
...
if (PL_pending_ident)
return REPORT(S_pending_ident(aTHX));
...
####
--- toke.c.orig 2005-10-18 19:47:57.000000000 +0100
+++ toke.c 2005-10-18 19:48:43.000000000 +0100
@@ -3169,7 +3169,7 @@
if (PL_expect != XOPERATOR) {
s = scan_ident(s, PL_bufend, PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
PL_expect = XOPERATOR;
- force_ident(PL_tokenbuf, '*');
+ PL_pending_ident = '*';
if (!*PL_tokenbuf)
PREREF('*');
TERM('*');
####
syntax error at ../lib/vars.pm line 29, near "*$sym "
####
$ ./miniperl -DT -ce '*$x'
### 0:LEX_NORMAL/XSTATE "\n;"
### <== '*'
### 1:LEX_NORMAL/XREF "$x\n"
### Pending identifier ''
### <== WORD(opval=op_const) PV(""\0)
### 1:LEX_NORMAL/XREF "$x\n"
### <== '$'
### 1:LEX_NORMAL/XOPERATOR ";"
### Pending identifier '$x'
### <== WORD(opval=op_const) PV("x"\0)
### 1:LEX_NORMAL/XOPERATOR ";"
### <== ';'
### 1:LEX_NORMAL/XSTATE ""
### Tokener got EOF
### <== EOF
syntax error at -e line 1, next char $
-e had compilation errors.
####
$ ./miniperl -DT -ce '%$x'
### 0:LEX_NORMAL/XSTATE "\n;"
### <== '%'
### 1:LEX_NORMAL/XREF "$x\n"
### <== '$'
### 1:LEX_NORMAL/XOPERATOR ";"
### Pending identifier '$x'
### <== WORD(opval=op_const) PV("x"\0)
### 1:LEX_NORMAL/XOPERATOR ";"
### <== ';'
### 1:LEX_NORMAL/XSTATE ""
### Tokener got EOF
### <== EOF
EXECUTING...
-e syntax OK
####
--- toke.c.orig 2005-10-18 19:47:57.000000000 +0100
+++ toke.c 2005-10-18 20:16:52.000000000 +0100
@@ -3167,11 +3167,11 @@
case '*':
if (PL_expect != XOPERATOR) {
- s = scan_ident(s, PL_bufend, PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
- PL_expect = XOPERATOR;
- force_ident(PL_tokenbuf, '*');
- if (!*PL_tokenbuf)
+ PL_tokenbuf[0] = '*';
+ s = scan_ident(s, PL_bufend, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, TRUE);
+ if (!PL_tokenbuf[1])
PREREF('*');
+ PL_pending_ident = '*';
TERM('*');
}
s++;
####
Global symbol "%DELETE" requires explicit package name at lib/Config_heavy.pl line 1158
####
*DELETE = \&STORE;
####
$ ./miniperl -ce '*foo'
-e syntax OK
$ ./miniperl -ce 'use strict; *foo'
Global symbol "%foo" requires explicit package name at -e line 1.
-e had compilation errors.
####
$ fgrep 'explicit package name' *.c
gv.c: "Global symbol \"%s%s\" requires explicit package name",
####
$ gdb --args ./miniperl -e '*foo'
(gdb) br Perl_gv_fetchpvn_flags
Breakpoint 1 at 0x806c485: file gv.c, line 710.
(gdb) condition 1 nambeg[0] == 'f'
(gdb) run
Starting program: /local/build/perl-current/miniperl -e \*foo
[New Thread 1074334048 (LWP 2919)]
[Switching to Thread 1074334048 (LWP 2919)]
Breakpoint 1, Perl_gv_fetchpvn_flags (my_perl=0x8199720,
nambeg=0x8199ca9 "foo", full_len=3, flags=1, sv_type=12) at gv.c:710
710 register const char *name = nambeg;
(gdb) bt
#0 Perl_gv_fetchpvn_flags (my_perl=0x8199720, nambeg=0x8199ca9 "foo",
full_len=3, flags=1, sv_type=12) at gv.c:710
#1 0x0806c406 in Perl_gv_fetchpv (my_perl=0x8199720, nambeg=0x8199ca9 "foo",
add=1, sv_type=12) at gv.c:696
#2 0x08087238 in S_pending_ident (my_perl=0x8199720) at toke.c:5669
#3 0x08076115 in Perl_yylex (my_perl=0x8199720) at toke.c:2431
#4 0x08092b5b in Perl_yyparse (my_perl=0x8199720) at perly.c:412
#5 0x08063ebc in S_parse_body (my_perl=0x8199720, env=0x0,
xsinit=0x804bb65 ) at perl.c:2136
#6 0x08062d16 in perl_parse (my_perl=0x8199720, xsinit=0x804bb65 ,
argc=3, argv=0xbffff3f4, env=0x0) at perl.c:1542
#7 0x0804baeb in main (argc=3, argv=0xbffff3f4, env=0xbffff404)
at miniperlmain.c:101
#8 0x42015704 in __libc_start_main () from /lib/tls/libc.so.6
####
gv_fetchpv(PL_tokenbuf+1, PL_in_eval ? (GV_ADDMULTI | GV_ADDINEVAL) : TRUE,
((PL_tokenbuf[0] == '$') ? SVt_PV
: (PL_tokenbuf[0] == '@') ? SVt_PVAV
: SVt_PVHV));
####
--- toke.c.1 2005-10-18 20:53:32.000000000 +0100
+++ toke.c 2005-10-18 20:54:34.000000000 +0100
@@ -5666,6 +5666,7 @@
gv_fetchpv(PL_tokenbuf+1, PL_in_eval ? (GV_ADDMULTI | GV_ADDINEVAL) : TRUE,
((PL_tokenbuf[0] == '$') ? SVt_PV
: (PL_tokenbuf[0] == '@') ? SVt_PVAV
+ : (PL_tokenbuf[0] == '*') ? SVt_PVGV
: SVt_PVHV));
return WORD;
}
####
$ ./perl -MO=Concise -e 'my *foo'
Can't declare private glob in "my" at -e line 1, at EOF
-e had compilation errors.
4 <@> leave[1 ref] KP/REFC ->(end)
1 <0> enter ->2
2 <;> nextstate(main 1 -e:1) ->3
3 <0> padgv[*foo:1,2] ->4
####
$ fgrep "Can't declare" *.c
op.c: "Can't declare class for non-scalar %s in \"%s\"",
op.c: yyerror(Perl_form(aTHX_ "Can't declare %s in %s",
op.c: yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
opmini.c: "Can't declare class for non-scalar %s in \"%s\"",
opmini.c: yyerror(Perl_form(aTHX_ "Can't declare %s in %s",
opmini.c: yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
####
else if (type != OP_PADSV &&
type != OP_PADAV &&
type != OP_PADHV &&
type != OP_PUSHMARK)
{
yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
OP_DESC(o),
PL_in_my == KEY_our ? "our" : "my"));
return o;
}
####
--- op.c.1 2005-10-18 21:03:51.000000000 +0100
+++ op.c 2005-10-18 21:04:11.000000000 +0100
@@ -1704,6 +1704,7 @@
else if (type != OP_PADSV &&
type != OP_PADAV &&
type != OP_PADHV &&
+ type != OP_PADGV &&
type != OP_PUSHMARK)
{
yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
####
$ ./perl -e 'my *foo'
OP_PADGV NOT YET IMPLEMENTED at -e line 1.
####
--- pp.c.orig 2005-10-18 19:16:07.000000000 +0100
+++ pp.c 2005-10-18 22:23:28.000000000 +0100
@@ -127,6 +127,15 @@
RETURN;
}
+PP(pp_padgv)
+{
+ dSP; dTARGET;
+ XPUSHs(TARG);
+ if (PL_op->op_private & OPpLVAL_INTRO)
+ SAVECLEARSV(PAD_SVl(PL_op->op_targ));
+ RETURN;
+}
+
PP(pp_padany)
{
DIE(aTHX_ "NOT IMPL LINE %d",__LINE__);
####
$ ./perl -e 'my *foo = *bar'
Can't modify private glob in scalar assignment at -e line 1, at EOF
####
$ fgrep "Can't modify" *.c
op.c: yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
####
--- op.c.2 2005-10-18 21:43:38.000000000 +0100
+++ op.c 2005-10-18 21:44:12.000000000 +0100
@@ -1222,6 +1222,7 @@
o->op_private |= OPpMAYBE_LVSUB;
/* FALL THROUGH */
case OP_PADSV:
+ case OP_PADGV:
PL_modcount++;
if (!type) /* local() */
Perl_croak(aTHX_ "Can't localize lexical variable %s",
####
$ ./perl -we 'my *foo = *bar; print *foo, "\n"'
Name "main::bar" used only once: possible typo at -e line 1.
*main::bar
####
$ ./perl -we 'my *foo = *bar; $bar = "Hello, world!\n"; print ${*foo}'
Hello, world!
####
$ ./perl -we 'my *foo; print *foo{NAME}'
Segmentation fault
####
--- pp.c.1 2005-10-18 22:30:22.000000000 +0100
+++ pp.c 2005-10-19 00:47:33.000000000 +0100
@@ -130,9 +130,15 @@
PP(pp_padgv)
{
dSP; dTARGET;
- XPUSHs(TARG);
- if (PL_op->op_private & OPpLVAL_INTRO)
- SAVECLEARSV(PAD_SVl(PL_op->op_targ));
+ if (PL_op->op_private & OPpLVAL_INTRO) {
+ GV *gen_gv = newGVgen("lexical");
+ sv_upgrade(TARG, SVt_RV);
+ SvREFCNT_inc((SV *)gen_gv);
+ SvRV_set(TARG, (SV *)gen_gv);
+ SvROK_on(TARG);
+ SAVECLEARSV(PAD_SVl(PL_op->op_targ));
+ }
+ XPUSHs(SvRV(TARG));
RETURN;
}
####
$ ./perl -wle 'print my *x'
*lexical::_GEN_0
$ ./perl -wle 'my *x = *foo; $foo = "Nice!"; print ${*x}'
Nice!
$ ./perl -wle 'my *x = *foo; my *y = *x; $foo = "Even nicer!"; print ${*y}'
Even nicer!
$ ./perl -wle 'my *x = \23; ${*x} = 24'
Modification of a read-only value attempted at -e line 1.
$ ./perl -wle 'my *x = \23; *foo = *x; print $foo; $foo = 24'
23
Modification of a read-only value attempted at -e line 1.
####
sub foo {
my *foo = shift;
sub {${*foo}}
}
my $x = foo(*foo);
$foo = "Hmm";
print $x->();
my $y = foo(\23);
print $y->();
####
$ ./perl -wle 'for(1..10) {my *x} print sort keys %lexical::'
_GEN_0_GEN_1_GEN_2_GEN_3_GEN_4_GEN_5_GEN_6_GEN_7_GEN_8_GEN_9
####
$ ./perl -e 'while (1) {my *foo}'
####
--- pp.c.3 2005-10-19 01:26:19.000000000 +0100
+++ pp.c 2005-10-19 01:34:42.000000000 +0100
@@ -136,6 +136,7 @@
SvREFCNT_inc((SV *)gen_gv);
SvRV_set(TARG, (SV *)gen_gv);
SvROK_on(TARG);
+ hv_delete(GvSTASH(gen_gv), GvNAME(gen_gv), GvNAMELEN(gen_gv), 0);
SAVECLEARSV(PAD_SVl(PL_op->op_targ));
}
XPUSHs(SvRV(TARG));
####
$ ./perl -wle 'for (1..10) {print \my *foo}'
GLOB(0x81b22d8)
GLOB(0x81b22f8)
GLOB(0x81b22b8)
GLOB(0x81b22d8)
GLOB(0x81b22f8)
GLOB(0x81b22b8)
GLOB(0x81b22d8)
GLOB(0x81b22f8)
GLOB(0x81b22b8)
GLOB(0x81b22d8)
####
#!./perl
use Test::More tests => 7;
BEGIN {
# This is in a BEGIN block so that it will run even if
# the syntax causes a compilation error.
eval q{ my *foo };
ok(!$@, "Syntactically okay.");
}
{
my *foo = *bar;
is(*foo, "*main::bar", "Visible within scope,");
}
is(*foo, "*main::foo", "yet invisible without it.");
{
my *foo;
is(*foo{PACKAGE}, 'lexical', "Package is 'lexical'");
ok(!keys %lexical::, "Glob does not really exist.");
}
sub foo {
my *foo = shift;
sub {
return ${*foo};
}
}
my @foo = map foo($_), \(17, 23);
is($foo[0]->(), 17, 'Closure test ($foo[0] == 17)');
is($foo[1]->(), 23, 'Closure test ($foo[1] == 23)');
####
--- ext/Opcode/Opcode.pm.orig 2005-10-19 01:08:11.000000000 +0100
+++ ext/Opcode/Opcode.pm 2005-10-19 01:08:28.000000000 +0100
@@ -394,7 +394,7 @@
gvsv gv gelem
- padsv padav padhv padany
+ padsv padav padhv padgv padany
rv2gv refgen srefgen ref
####
--- ext/Safe/t/safeops.t.orig 2005-10-19 02:13:20.000000000 +0100
+++ ext/Safe/t/safeops.t 2005-10-19 02:13:52.000000000 +0100
@@ -19,7 +19,7 @@
}
use strict;
-use Test::More tests => 354;
+use Test::More tests => 355;
use Safe;
# Read the op names and descriptions directly from opcode.pl
@@ -72,6 +72,7 @@
SKIP my $x # padsv
SKIP my @x # padav
SKIP my %x # padhv
+SKIP my *x # padgv
SKIP (not implemented) # padany
SKIP split /foo/ # pushre
*x # rv2gv
####
--- ext/B/t/optree_concise.t.orig 2005-10-19 02:16:20.000000000 +0100
+++ ext/B/t/optree_concise.t 2005-10-19 02:16:37.000000000 +0100
@@ -183,13 +183,13 @@
UNOP (0x82b0918) leavesub [1]
LISTOP (0x82b08d8) lineseq
COP (0x82b0880) nextstate
- UNOP (0x82b0860) null [15]
+ UNOP (0x82b0860) null [16]
PADOP (0x82b0840) gvsv GV (0x82a818c) *a
EOT_EOT
# UNOP (0x8282310) leavesub [1]
# LISTOP (0x82822f0) lineseq
# COP (0x82822b8) nextstate
-# UNOP (0x812fc20) null [15]
+# UNOP (0x812fc20) null [16]
# SVOP (0x812fc00) gvsv GV (0x814692c) *a
EONT_EONT
####
--- patchlevel.h.orig 2005-10-19 03:31:04.000000000 +0100
+++ patchlevel.h 2005-10-19 03:32:24.000000000 +0100
@@ -122,6 +122,7 @@
static const char * const local_patches[] = {
NULL
,"DEVEL" STRINGIFY(PERL_PATCHNUM)
+ ,"LEXGLOB001 - lexically scoped globs!"
,NULL
};
####
...
Locally applied patches:
DEVEL25746
LEXGLOB001 - lexically scoped globs!
...