t/op/sselect.t See if 4 argument select works
t/op/stash.t See if %:: stashes work
t/op/stat.t See if stat works
+t/op/state.t See if state variables work
t/op/study.t See if study works
t/op/studytied.t See if study works with tied scalars
t/op/sub_lval.t See if lvalue subroutines work
if (GvASSUMECV(sv)) sv_catpv(d, "ASSUMECV,");
if (GvIN_PAD(sv)) sv_catpv(d, "IN_PAD,");
if (SvPAD_OUR(sv)) sv_catpv(d, "OUR,");
+ if (SvPAD_STATE(sv)) sv_catpv(d, "STATE,");
if (SvPAD_TYPED(sv)) sv_catpv(d, "TYPED,");
if (GvIMPORTED(sv)) {
sv_catpv(d, "IMPORT");
pda |PADLIST*|pad_new |int flags
pd |void |pad_undef |NN CV* cv
pd |PADOFFSET|pad_add_name |NN const char *name\
- |NULLOK HV* typestash|NULLOK HV* ourstash|bool clone
+ |NULLOK HV* typestash|NULLOK HV* ourstash|bool clone|bool state
pd |PADOFFSET|pad_add_anon |NN SV* sv|OPCODE op_type
pd |void |pad_check_dup |NN const char* name|bool is_our|NN const HV* ourstash
#ifdef DEBUGGING
#ifdef PERL_CORE
#define pad_new(a) Perl_pad_new(aTHX_ a)
#define pad_undef(a) Perl_pad_undef(aTHX_ a)
-#define pad_add_name(a,b,c,d) Perl_pad_add_name(aTHX_ a,b,c,d)
+#define pad_add_name(a,b,c,d,e) Perl_pad_add_name(aTHX_ a,b,c,d,e)
#define pad_add_anon(a,b) Perl_pad_add_anon(aTHX_ a,b)
#define pad_check_dup(a,b,c) Perl_pad_check_dup(aTHX_ a,b,c)
#endif
use Exporter (); # use #5
-our $VERSION = "0.67";
+our $VERSION = "0.68";
our @ISA = qw(Exporter);
our @EXPORT_OK = qw( set_style set_style_standard add_callback
concise_subref concise_cv concise_main
$priv{$_}{64} = "REFC" for ("leave", "leavesub", "leavesublv", "leavewrite");
$priv{"aassign"}{64} = "COMMON";
$priv{"aassign"}{32} = "PHASH" if $] < 5.009;
+$priv{"sassign"}{32} = "STATE";
$priv{"sassign"}{64} = "BKWARD";
$priv{$_}{64} = "RTIME" for ("match", "subst", "substcont", "qr");
@{$priv{"trans"}}{1,2,4,8,16,64} = ("<UTF", ">UTF", "IDENT", "SQUASH", "DEL",
$priv{"leaveloop"}{64} = "CONT";
@{$priv{$_}}{32,64,96} = ("DREFAV", "DREFHV", "DREFSV")
for (qw(rv2gv rv2sv padsv aelem helem));
+$priv{"padsv"}{16} = "STATE";
@{$priv{"entersub"}}{16,32,64} = ("DBG","TARG","NOMOD");
@{$priv{$_}}{4,8,128} = ("INARGS","AMPER","NO()") for ("entersub", "rv2cv");
$priv{"gv"}{32} = "EARLYCV";
+ 511 + 235 # B::Deparse, B
+ 588 + 190 # POSIX, IO::Socket
+ 3 * ($] > 5.009)
- + 14 * ($] >= 5.009003)
+ + 16 * ($] >= 5.009003)
- 22); # fudge
require_ok("B::Concise");
#define KEY_sqrt 207
#define KEY_srand 208
#define KEY_stat 209
-#define KEY_study 210
-#define KEY_sub 211
-#define KEY_substr 212
-#define KEY_symlink 213
-#define KEY_syscall 214
-#define KEY_sysopen 215
-#define KEY_sysread 216
-#define KEY_sysseek 217
-#define KEY_system 218
-#define KEY_syswrite 219
-#define KEY_tell 220
-#define KEY_telldir 221
-#define KEY_tie 222
-#define KEY_tied 223
-#define KEY_time 224
-#define KEY_times 225
-#define KEY_tr 226
-#define KEY_truncate 227
-#define KEY_uc 228
-#define KEY_ucfirst 229
-#define KEY_umask 230
-#define KEY_undef 231
-#define KEY_unless 232
-#define KEY_unlink 233
-#define KEY_unpack 234
-#define KEY_unshift 235
-#define KEY_untie 236
-#define KEY_until 237
-#define KEY_use 238
-#define KEY_utime 239
-#define KEY_values 240
-#define KEY_vec 241
-#define KEY_wait 242
-#define KEY_waitpid 243
-#define KEY_wantarray 244
-#define KEY_warn 245
-#define KEY_when 246
-#define KEY_while 247
-#define KEY_write 248
-#define KEY_x 249
-#define KEY_xor 250
-#define KEY_y 251
+#define KEY_state 210
+#define KEY_study 211
+#define KEY_sub 212
+#define KEY_substr 213
+#define KEY_symlink 214
+#define KEY_syscall 215
+#define KEY_sysopen 216
+#define KEY_sysread 217
+#define KEY_sysseek 218
+#define KEY_system 219
+#define KEY_syswrite 220
+#define KEY_tell 221
+#define KEY_telldir 222
+#define KEY_tie 223
+#define KEY_tied 224
+#define KEY_time 225
+#define KEY_times 226
+#define KEY_tr 227
+#define KEY_truncate 228
+#define KEY_uc 229
+#define KEY_ucfirst 230
+#define KEY_umask 231
+#define KEY_undef 232
+#define KEY_unless 233
+#define KEY_unlink 234
+#define KEY_unpack 235
+#define KEY_unshift 236
+#define KEY_untie 237
+#define KEY_until 238
+#define KEY_use 239
+#define KEY_utime 240
+#define KEY_values 241
+#define KEY_vec 242
+#define KEY_wait 243
+#define KEY_waitpid 244
+#define KEY_wantarray 245
+#define KEY_warn 246
+#define KEY_when 247
+#define KEY_while 248
+#define KEY_write 249
+#define KEY_x 250
+#define KEY_xor 251
+#define KEY_y 252
/* ex: set ro: */
sqrt
srand
stat
+state
study
sub
substr
if (PL_in_my_stash && *name != '$') {
yyerror(Perl_form(aTHX_
"Can't declare class for non-scalar %s in \"%s\"",
- name, is_our ? "our" : "my"));
+ name,
+ is_our ? "our" : PL_in_my == KEY_state ? "state" : "my"));
}
/* allocate a spare slot and store the name in that slot */
? (PL_curstash && !strEQ(name,"$_") ? PL_curstash : PL_defstash)
: NULL
),
- 0 /* not fake */
+ 0, /* not fake */
+ PL_in_my == KEY_state
);
return off;
}
type == OP_RV2HV) { /* XXX does this let anything illegal in? */
if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */
yyerror(Perl_form(aTHX_ "Can't declare %s in %s",
- OP_DESC(o), PL_in_my == KEY_our ? "our" : "my"));
+ OP_DESC(o),
+ PL_in_my == KEY_our ? "our" : PL_in_my == KEY_state ? "state" : "my"));
} else if (attrs) {
GV * const gv = cGVOPx_gv(cUNOPo->op_first);
PL_in_my = FALSE;
{
yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
OP_DESC(o),
- PL_in_my == KEY_our ? "our" : "my"));
+ PL_in_my == KEY_our ? "our" : PL_in_my == KEY_state ? "state" : "my"));
return o;
}
else if (attrs && type != OP_PUSHMARK) {
}
o->op_flags |= OPf_MOD;
o->op_private |= OPpLVAL_INTRO;
+ if (PL_in_my == KEY_state)
+ o->op_private |= OPpPAD_STATE;
return o;
}
if (sigil && (*s == ';' || *s == '=')) {
Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS),
"Parentheses missing around \"%s\" list",
- lex ? (PL_in_my == KEY_our ? "our" : "my")
+ lex ? (PL_in_my == KEY_our ? "our" : PL_in_my == KEY_state ? "state" : "my")
: "local");
}
}
return kid;
}
}
+ if (kid->op_sibling) {
+ OP *kkid = kid->op_sibling;
+ if (kkid->op_type == OP_PADSV
+ && (kkid->op_private & OPpLVAL_INTRO)
+ && SvPAD_STATE(*av_fetch(PL_comppad_name, kkid->op_targ, FALSE))) {
+ o->op_private |= OPpASSIGN_STATE;
+ /* hijacking PADSTALE for uninitialized state variables */
+ SvPADSTALE_on(PAD_SVl(kkid->op_targ));
+ }
+ }
return o;
}
#define OPpASSIGN_BACKWARDS 64 /* Left & right switched. */
#define OPpASSIGN_CV_TO_GV 128 /* Possible optimisation for constants. */
+/* Private for OP_[AS]ASSIGN */
+#define OPpASSIGN_STATE 32 /* Assign to a "state" variable */
+
/* Private for OP_MATCH and OP_SUBST{,CONST} */
#define OPpRUNTIME 64 /* Pattern coming in on the stack */
#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 */
+ /* OP_PADSV only */
+#define OPpPAD_STATE 16 /* is a "state" pad */
/* for OP_RV2?V, lower bits carry hints (currently only HINT_STRICT_REFS) */
/* OP_RV2GV only */
#include "EXTERN.h"
#define PERL_IN_PAD_C
#include "perl.h"
+#include "keywords.h"
#define PAD_MAX 999999999
*/
PADOFFSET
-Perl_pad_add_name(pTHX_ const char *name, HV* typestash, HV* ourstash, bool fake)
+Perl_pad_add_name(pTHX_ const char *name, HV* typestash, HV* ourstash, bool fake, bool state)
{
dVAR;
const PADOFFSET offset = pad_alloc(OP_PADSV, SVs_PADMY);
OURSTASH_set(namesv, ourstash);
SvREFCNT_inc_simple_void_NN(ourstash);
}
+ else if (state) {
+ SvPAD_STATE_on(namesv);
+ }
av_store(PL_comppad_name, offset, namesv);
if (fake) {
break; /* "our" masking "our" */
Perl_warner(aTHX_ packWARN(WARN_MISC),
"\"%s\" variable %s masks earlier declaration in same %s",
- (is_our ? "our" : "my"),
+ (is_our ? "our" : PL_in_my == KEY_my ? "my" : "state"),
name,
(SvIVX(sv) == PAD_MAX ? "scope" : "statement"));
--off;
SvPAD_TYPED(*out_name_sv)
? SvSTASH(*out_name_sv) : NULL,
OURSTASH(*out_name_sv),
- 1 /* fake */
+ 1, /* fake */
+ 0 /* not a state variable */
);
new_namesv = AvARRAY(PL_comppad_name)[new_offset];
EXTCONST char PL_no_func[]
INIT("The %s function is unimplemented");
EXTCONST char PL_no_myglob[]
- INIT("\"my\" variable %s can't be in a package");
+ INIT("\"%s\" variable %s can't be in a package");
EXTCONST char PL_no_localize_ref[]
INIT("Can't localize through a reference");
EXTCONST char PL_memory_wrap[]
delete do END else eval elsif exists for format foreach given grep
goto glob INIT if last local m my map next no our pos print printf
package prototype q qr qq qw qx redo return require s scalar sort
- split study sub tr tie tied use undef until untie unless when while
- y);
+ split state study sub tr tie tied use undef until untie unless when
+ while y);
my @neg = qw(__FILE__ __LINE__ __PACKAGE__ and abs alarm atan2 accept bless
break bind binmode CORE cmp chr cos chop close chdir chomp chmod
If fake, it means we're cloning an existing entry
- PADOFFSET pad_add_name(const char *name, HV* typestash, HV* ourstash, bool clone)
+ PADOFFSET pad_add_name(const char *name, HV* typestash, HV* ourstash, bool clone, bool state)
=for hackers
Found in file pad.c
SV * const temp = left;
left = right; right = temp;
}
+ else if (PL_op->op_private & OPpASSIGN_STATE) {
+ if (SvPADSTALE(right))
+ SvPADSTALE_off(right);
+ else
+ RETURN; /* ignore assignment */
+ }
if (PL_tainting && PL_tainted && !SvTAINTED(left))
TAINT_NOT;
if (PL_op->op_private & OPpASSIGN_CV_TO_GV) {
XPUSHs(TARG);
if (PL_op->op_flags & OPf_MOD) {
if (PL_op->op_private & OPpLVAL_INTRO)
- SAVECLEARSV(PAD_SVl(PL_op->op_targ));
+ if (!(PL_op->op_private & OPpPAD_STATE))
+ SAVECLEARSV(PAD_SVl(PL_op->op_targ));
if (PL_op->op_private & OPpDEREF) {
PUTBACK;
vivify_ref(PAD_SVl(PL_op->op_targ), PL_op->op_private & OPpDEREF);
PERL_CALLCONV void Perl_pad_undef(pTHX_ CV* cv)
__attribute__nonnull__(pTHX_1);
-PERL_CALLCONV PADOFFSET Perl_pad_add_name(pTHX_ const char *name, HV* typestash, HV* ourstash, bool clone)
+PERL_CALLCONV PADOFFSET Perl_pad_add_name(pTHX_ const char *name, HV* typestash, HV* ourstash, bool clone, bool state)
__attribute__nonnull__(pTHX_1);
PERL_CALLCONV PADOFFSET Perl_pad_add_anon(pTHX_ SV* sv, OPCODE op_type)
#define SVphv_CLONEABLE 0x00008000 /* PVHV (stashes) clone its objects */
#define SVs_PADSTALE 0x00010000 /* lexical has gone out of scope */
+#define SVpad_STATE 0x00010000 /* pad name is a "state" var */
#define SVs_PADTMP 0x00020000 /* in use as tmp */
#define SVpad_TYPED 0x00020000 /* pad name is a Typed Lexical */
#define SVs_PADMY 0x00040000 /* in use a "my" variable */
keys live on shared string table */
/* PVNV, PVMG, PVGV, presumably only inside pads */
#define SVpad_NAME 0x40000000 /* This SV is a name in the PAD, so
- SVpad_TYPED and SVpad_OUR apply */
+ SVpad_TYPED, SVpad_OUR and
+ SVpad_STATE apply */
/* PVAV */
#define SVpav_REAL 0x40000000 /* free old entries */
/* PVHV */
((SvFLAGS(sv) & (SVpad_NAME|SVpad_OUR)) == (SVpad_NAME|SVpad_OUR))
#define SvPAD_OUR_on(sv) (SvFLAGS(sv) |= SVpad_NAME|SVpad_OUR)
+#define SvPAD_STATE(sv) \
+ ((SvFLAGS(sv) & (SVpad_NAME|SVpad_STATE)) == (SVpad_NAME|SVpad_STATE))
+#define SvPAD_STATE_on(sv) (SvFLAGS(sv) |= SVpad_NAME|SVpad_STATE)
+
#define OURSTASH(sv) \
(SvPAD_OUR(sv) ? ((XPVMG*) SvANY(sv))->xmg_u.xmg_ourstash : NULL)
#define OURSTASH_set(sv, st) \
--- /dev/null
+#!./perl -w
+
+BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+ require './test.pl';
+}
+
+use strict;
+
+plan tests => 19;
+
+ok( ! defined state $uninit, q(state vars are undef by default) );
+
+sub stateful {
+ state $x;
+ state $y = 1;
+ my $z = 2;
+ return ($x++, $y++, $z++);
+}
+
+my ($x, $y, $z) = stateful();
+is( $x, 0, 'uninitialized state var' );
+is( $y, 1, 'initialized state var' );
+is( $z, 2, 'lexical' );
+
+($x, $y, $z) = stateful();
+is( $x, 1, 'incremented state var' );
+is( $y, 2, 'incremented state var' );
+is( $z, 2, 'reinitialized lexical' );
+
+($x, $y, $z) = stateful();
+is( $x, 2, 'incremented state var' );
+is( $y, 3, 'incremented state var' );
+is( $z, 2, 'reinitialized lexical' );
+
+sub nesting {
+ state $foo = 10;
+ my $t;
+ { state $bar = 12; $t = ++$bar }
+ ++$foo;
+ return ($foo, $t);
+}
+
+($x, $y) = nesting();
+is( $x, 11, 'outer state var' );
+is( $y, 13, 'inner state var' );
+
+($x, $y) = nesting();
+is( $x, 12, 'outer state var' );
+is( $y, 14, 'inner state var' );
+
+sub generator {
+ my $outer;
+ # we use $outer to generate a closure
+ sub { ++$outer; ++state $x }
+}
+
+my $f1 = generator();
+is( $f1->(), 1, 'generator 1' );
+is( $f1->(), 2, 'generator 1' );
+my $f2 = generator();
+is( $f2->(), 1, 'generator 2' );
+is( $f1->(), 3, 'generator 1 again' );
+is( $f2->(), 2, 'generator 2 once more' );
case KEY_our:
case KEY_my:
+ case KEY_state:
PL_in_my = tmp;
s = SKIPSPACE1(s);
if (isIDFIRST_lazy_if(s,UTF)) {
}
else {
if (strchr(PL_tokenbuf,':'))
- yyerror(Perl_form(aTHX_ PL_no_myglob,PL_tokenbuf));
+ yyerror(Perl_form(aTHX_ PL_no_myglob,
+ PL_in_my == KEY_my ? "my" : "state", PL_tokenbuf));
yylval.opval = newOP(OP_PADANY, 0);
yylval.opval->op_targ = allocmy(PL_tokenbuf);
I32
Perl_keyword (pTHX_ const char *name, I32 len)
{
- dVAR;
+ dVAR;
switch (len)
{
case 1: /* 5 tokens of length 1 */
switch (name[1])
{
case 'a':
- switch (name[2])
- {
- case 'i':
- if (name[3] == 't')
- { /* wait */
- return -KEY_wait;
- }
+ switch (name[2])
+ {
+ case 'i':
+ if (name[3] == 't')
+ { /* wait */
+ return -KEY_wait;
+ }
- goto unknown;
+ goto unknown;
- case 'r':
- if (name[3] == 'n')
- { /* warn */
- return -KEY_warn;
- }
+ case 'r':
+ if (name[3] == 'n')
+ { /* warn */
+ return -KEY_warn;
+ }
- goto unknown;
+ goto unknown;
- default:
- goto unknown;
- }
+ default:
+ goto unknown;
+ }
case 'h':
if (name[2] == 'e' &&
name[3] == 'n')
{ /* when */
return (FEATURE_IS_ENABLED("switch") ? KEY_when : 0);
- }
+ }
- goto unknown;
+ goto unknown;
- default:
- goto unknown;
- }
+ default:
+ goto unknown;
+ }
default:
goto unknown;
}
- case 5: /* 38 tokens of length 5 */
+ case 5: /* 39 tokens of length 5 */
switch (name[0])
{
case 'B':
{
case 'l':
if (name[2] == 'e' &&
- name[3] == 's' &&
- name[4] == 's')
- { /* bless */
- return -KEY_bless;
- }
+ name[3] == 's' &&
+ name[4] == 's')
+ { /* bless */
+ return -KEY_bless;
+ }
- goto unknown;
+ goto unknown;
case 'r':
if (name[2] == 'e' &&
goto unknown;
case 't':
- if (name[2] == 'u' &&
- name[3] == 'd' &&
- name[4] == 'y')
- { /* study */
- return KEY_study;
- }
+ switch (name[2])
+ {
+ case 'a':
+ if (name[3] == 't' &&
+ name[4] == 'e')
+ { /* state */
+ return KEY_state;
+ }
- goto unknown;
+ goto unknown;
+
+ case 'u':
+ if (name[3] == 'd' &&
+ name[4] == 'y')
+ { /* study */
+ return KEY_study;
+ }
+
+ goto unknown;
+
+ default:
+ goto unknown;
+ }
default:
goto unknown;
case 'i':
if (name[4] == 'n' &&
- name[5] == 'e' &&
- name[6] == 'd')
- { /* defined */
- return KEY_defined;
- }
+ name[5] == 'e' &&
+ name[6] == 'd')
+ { /* defined */
+ return KEY_defined;
+ }
- goto unknown;
+ goto unknown;
- default:
- goto unknown;
- }
+ default:
+ goto unknown;
+ }
}
goto unknown;
projects / p5sagit/p5-mst-13.2.git / commitdiff