t/pragma/strict-vars Tests of "use strict 'vars'" for strict.t
t/pragma/strict.t See if strictures work
t/pragma/subs.t See if subroutine pseudo-importation works
+t/pragma/sub_lval.t See if lvalue subroutines work
t/pragma/utf8.t See if utf8 operations work
t/pragma/warn/1global Tests of global warnings for warnings.t
t/pragma/warn/2use Tests for "use warnings" for warnings.t
AV * argarray;
U16 olddepth;
U8 hasargs;
+ U8 lval; /* XXX merge lval and hasargs? */
};
#define PUSHSUB(cx) \
cx->blk_sub.cv = cv; \
cx->blk_sub.olddepth = CvDEPTH(cv); \
- cx->blk_sub.hasargs = hasargs;
+ cx->blk_sub.hasargs = hasargs; \
+ cx->blk_sub.lval = PL_op->op_private & \
+ (OPpLVAL_INTRO|OPpENTERSUB_INARGS);
#define PUSHFORMAT(cx) \
cx->blk_sub.cv = cv; \
(esp. useful for special XSUBs) */
#define CVf_METHOD 0x0040 /* CV is explicitly marked as a method */
#define CVf_LOCKED 0x0080 /* CV locks itself or first arg on entry */
+#define CVf_LVALUE 0x0100 /* CV return value can be used as lvalue */
#define CvCLONE(cv) (CvFLAGS(cv) & CVf_CLONE)
#define CvCLONE_on(cv) (CvFLAGS(cv) |= CVf_CLONE)
#define CvLOCKED_on(cv) (CvFLAGS(cv) |= CVf_LOCKED)
#define CvLOCKED_off(cv) (CvFLAGS(cv) &= ~CVf_LOCKED)
+#define CvLVALUE(cv) (CvFLAGS(cv) & CVf_LVALUE)
+#define CvLVALUE_on(cv) (CvFLAGS(cv) |= CVf_LVALUE)
+#define CvLVALUE_off(cv) (CvFLAGS(cv) &= ~CVf_LVALUE)
+
#define CvEVAL(cv) (CvUNIQUE(cv) && !SvFAKE(cv))
#define CvEVAL_on(cv) (CvUNIQUE_on(cv),SvFAKE_off(cv))
#define CvEVAL_off(cv) CvUNIQUE_off(cv)
else if (o->op_type == OP_FLOP) {
if (o->op_private & OPpFLIP_LINENUM)
sv_catpv(tmpsv, ",LINENUM");
+ } else if (o->op_type == OP_RV2CV) {
+ if (o->op_private & OPpLVAL_INTRO)
+ sv_catpv(tmpsv, ",INTRO");
}
if (o->op_flags & OPf_MOD && o->op_private & OPpLVAL_INTRO)
sv_catpv(tmpsv, ",INTRO");
#define pp_leaveeval Perl_pp_leaveeval
#define pp_leaveloop Perl_pp_leaveloop
#define pp_leavesub Perl_pp_leavesub
+#define pp_leavesublv Perl_pp_leavesublv
#define pp_leavetry Perl_pp_leavetry
#define pp_leavewrite Perl_pp_leavewrite
#define pp_left_shift Perl_pp_left_shift
#define pp_leaveeval() Perl_pp_leaveeval(aTHX)
#define pp_leaveloop() Perl_pp_leaveloop(aTHX)
#define pp_leavesub() Perl_pp_leavesub(aTHX)
+#define pp_leavesublv() Perl_pp_leavesublv(aTHX)
#define pp_leavetry() Perl_pp_leavetry(aTHX)
#define pp_leavewrite() Perl_pp_leavewrite(aTHX)
#define pp_left_shift() Perl_pp_left_shift(aTHX)
#define pp_leaveloop Perl_pp_leaveloop
#define Perl_pp_leavesub CPerlObj::Perl_pp_leavesub
#define pp_leavesub Perl_pp_leavesub
+#define Perl_pp_leavesublv CPerlObj::Perl_pp_leavesublv
+#define pp_leavesublv Perl_pp_leavesublv
#define Perl_pp_leavetry CPerlObj::Perl_pp_leavetry
#define pp_leavetry Perl_pp_leavetry
#define Perl_pp_leavewrite CPerlObj::Perl_pp_leavewrite
rv2cv anoncode prototype
- entersub leavesub return method method_named -- XXX loops via recursion?
+ entersub leavesub leavesublv return method method_named -- XXX loops via recursion?
leaveeval -- needed for Safe to operate, is safe without entereval
explicitly taken with the C<lock> operator immediately after the
subroutine is entered.
+=item lvalue
+
+Setting this attribute enables the subroutine to be used in
+lvalue context. See L<perlsub/"Lvalue subroutines">.
+
=back
=cut
return CVf_METHOD;
else if (strnEQ(attr, "locked", 6))
return CVf_LOCKED;
+ else if (strnEQ(attr, "lvalue", 6))
+ return CVf_LVALUE;
else
return 0;
}
#define Perl_pp_leavesub pPerl->Perl_pp_leavesub
#undef pp_leavesub
#define pp_leavesub Perl_pp_leavesub
+#undef Perl_pp_leavesublv
+#define Perl_pp_leavesublv pPerl->Perl_pp_leavesublv
+#undef pp_leavesublv
+#define pp_leavesublv Perl_pp_leavesublv
#undef Perl_pp_leavetry
#define Perl_pp_leavetry pPerl->Perl_pp_leavetry
#undef pp_leavetry
null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
break;
}
+ else { /* lvalue subroutine call */
+ o->op_private |= OPpLVAL_INTRO;
+ if (type == OP_GREPSTART || type == OP_ENTERSUB) {
+ /* Backward compatibility mode: */
+ o->op_private |= OPpENTERSUB_INARGS;
+ break;
+ }
+ else { /* Compile-time error message: */
+ OP *kid = cUNOPo->op_first;
+ CV *cv;
+ OP *okid;
+
+ if (kid->op_type == OP_PUSHMARK)
+ goto skip_kids;
+ if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
+ Perl_croak(aTHX_
+ "panic: unexpected lvalue entersub "
+ "args: type/targ %ld:%ld",
+ (long)kid->op_type,kid->op_targ);
+ kid = kLISTOP->op_first;
+ skip_kids:
+ while (kid->op_sibling)
+ kid = kid->op_sibling;
+ if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) {
+ /* Indirect call */
+ if (kid->op_type == OP_METHOD_NAMED
+ || kid->op_type == OP_METHOD)
+ {
+ OP *new;
+
+ if (kid->op_sibling || kid->op_next != kid) {
+ yyerror("panic: unexpected optree near method call");
+ break;
+ }
+
+ NewOp(1101, new, 1, OP);
+ new->op_type = OP_RV2CV;
+ new->op_ppaddr = PL_ppaddr[OP_RV2CV];
+ new->op_next = new;
+ kid->op_sibling = new;
+ new->op_private |= OPpLVAL_INTRO;
+ break;
+ }
+
+ if (kid->op_type != OP_RV2CV)
+ Perl_croak(aTHX_
+ "panic: unexpected lvalue entersub "
+ "entry via type/targ %ld:%ld",
+ (long)kid->op_type,kid->op_targ);
+ kid->op_private |= OPpLVAL_INTRO;
+ break; /* Postpone until runtime */
+ }
+
+ okid = kid;
+ kid = kUNOP->op_first;
+ if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV)
+ kid = kUNOP->op_first;
+ if (kid->op_type == OP_NULL)
+ Perl_croak(aTHX_
+ "Unexpected constant lvalue entersub "
+ "entry via type/targ %ld:%ld",
+ (long)kid->op_type,kid->op_targ);
+ if (kid->op_type != OP_GV) {
+ /* Restore RV2CV to check lvalueness */
+ restore_2cv:
+ if (kid->op_next && kid->op_next != kid) { /* Happens? */
+ okid->op_next = kid->op_next;
+ kid->op_next = okid;
+ }
+ else
+ okid->op_next = Nullop;
+ okid->op_type = OP_RV2CV;
+ okid->op_targ = 0;
+ okid->op_ppaddr = PL_ppaddr[OP_RV2CV];
+ okid->op_private |= OPpLVAL_INTRO;
+ break;
+ }
+
+ cv = GvCV(kGVOP->op_gv);
+ if (!cv)
+ goto restore_2cv;
+ if (CvLVALUE(cv))
+ break;
+ }
+ }
/* FALL THROUGH */
default:
nomod:
break;
yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
(o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
- ? "do block" : PL_op_desc[o->op_type]),
+ ? "do block"
+ : (o->op_type == OP_ENTERSUB
+ ? "non-lvalue subroutine call"
+ : PL_op_desc[o->op_type])),
type ? PL_op_desc[type] : "local"));
return o;
}
}
- CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block));
+ if(CvLVALUE(cv)) {
+ CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0, scalarseq(block));
+ }
+ else {
+ CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block));
+ }
CvSTART(cv) = LINKLIST(CvROOT(cv));
CvROOT(cv)->op_next = 0;
peep(CvSTART(cv));
dTHR;
register OP* oldop = 0;
STRLEN n_a;
+ OP *last_composite = Nullop;
if (!o || o->op_seq)
return;
case OP_DBSTATE:
PL_curcop = ((COP*)o); /* for warnings */
o->op_seq = PL_op_seqmax++;
+ last_composite = Nullop;
break;
case OP_CONST:
&& (((LISTOP*)o)->op_first->op_sibling->op_targ
== o->op_next->op_targ))) {
goto ignore_optimization;
- } else {
+ }
+ else {
o->op_targ = o->op_next->op_targ;
o->op_private |= OPpTARGET_MY;
}
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->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;
: dowantarray())
/* Private for lvalues */
-#define OPpLVAL_INTRO 128 /* Lvalue must be localized */
+#define OPpLVAL_INTRO 128 /* Lvalue must be localized or lvalue sub */
/* Private for OP_AASSIGN */
#define OPpASSIGN_COMMON 64 /* Left & right have syms in common. */
/* OP_RV2CV only */
#define OPpENTERSUB_AMPER 8 /* Used & form to call. */
#define OPpENTERSUB_NOPAREN 128 /* bare sub call (without parens) */
+#define OPpENTERSUB_INARGS 4 /* Lval used as arg to a sub. */
/* OP_GV only */
#define OPpEARLY_CV 32 /* foo() called before sub foo was parsed */
/* OP_?ELEM only */
"method",
"entersub",
"leavesub",
+ "leavesublv",
"caller",
"warn",
"die",
"method lookup",
"subroutine entry",
"subroutine exit",
+ "lvalue subroutine exit",
"caller",
"warn",
"die",
Perl_pp_method,
Perl_pp_entersub,
Perl_pp_leavesub,
+ Perl_pp_leavesublv,
Perl_pp_caller,
Perl_pp_warn,
Perl_pp_die,
Perl_ck_method, /* method */
Perl_ck_subr, /* entersub */
Perl_ck_null, /* leavesub */
+ Perl_ck_null, /* leavesublv */
Perl_ck_fun, /* caller */
Perl_ck_fun, /* warn */
Perl_ck_fun, /* die */
0x00000240, /* method */
0x00004249, /* entersub */
0x00000200, /* leavesub */
+ 0x00000200, /* leavesublv */
0x00013608, /* caller */
0x0000481d, /* warn */
0x0000485d, /* die */
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
caller caller ck_fun t% S?
warn warn ck_fun imst@ L
die die ck_fun dimst@ L
OP_METHOD, /* 165 */
OP_ENTERSUB, /* 166 */
OP_LEAVESUB, /* 167 */
- OP_CALLER, /* 168 */
- OP_WARN, /* 169 */
- OP_DIE, /* 170 */
- OP_RESET, /* 171 */
- OP_LINESEQ, /* 172 */
- OP_NEXTSTATE, /* 173 */
- OP_DBSTATE, /* 174 */
- OP_UNSTACK, /* 175 */
- OP_ENTER, /* 176 */
- OP_LEAVE, /* 177 */
- OP_SCOPE, /* 178 */
- OP_ENTERITER, /* 179 */
- OP_ITER, /* 180 */
- OP_ENTERLOOP, /* 181 */
- OP_LEAVELOOP, /* 182 */
- OP_RETURN, /* 183 */
- OP_LAST, /* 184 */
- OP_NEXT, /* 185 */
- OP_REDO, /* 186 */
- OP_DUMP, /* 187 */
- OP_GOTO, /* 188 */
- OP_EXIT, /* 189 */
- OP_OPEN, /* 190 */
- OP_CLOSE, /* 191 */
- OP_PIPE_OP, /* 192 */
- OP_FILENO, /* 193 */
- OP_UMASK, /* 194 */
- OP_BINMODE, /* 195 */
- OP_TIE, /* 196 */
- OP_UNTIE, /* 197 */
- OP_TIED, /* 198 */
- OP_DBMOPEN, /* 199 */
- OP_DBMCLOSE, /* 200 */
- OP_SSELECT, /* 201 */
- OP_SELECT, /* 202 */
- OP_GETC, /* 203 */
- OP_READ, /* 204 */
- OP_ENTERWRITE, /* 205 */
- OP_LEAVEWRITE, /* 206 */
- OP_PRTF, /* 207 */
- OP_PRINT, /* 208 */
- OP_SYSOPEN, /* 209 */
- OP_SYSSEEK, /* 210 */
- OP_SYSREAD, /* 211 */
- OP_SYSWRITE, /* 212 */
- OP_SEND, /* 213 */
- OP_RECV, /* 214 */
- OP_EOF, /* 215 */
- OP_TELL, /* 216 */
- OP_SEEK, /* 217 */
- OP_TRUNCATE, /* 218 */
- OP_FCNTL, /* 219 */
- OP_IOCTL, /* 220 */
- OP_FLOCK, /* 221 */
- OP_SOCKET, /* 222 */
- OP_SOCKPAIR, /* 223 */
- OP_BIND, /* 224 */
- OP_CONNECT, /* 225 */
- OP_LISTEN, /* 226 */
- OP_ACCEPT, /* 227 */
- OP_SHUTDOWN, /* 228 */
- OP_GSOCKOPT, /* 229 */
- OP_SSOCKOPT, /* 230 */
- OP_GETSOCKNAME, /* 231 */
- OP_GETPEERNAME, /* 232 */
- OP_LSTAT, /* 233 */
- OP_STAT, /* 234 */
- OP_FTRREAD, /* 235 */
- OP_FTRWRITE, /* 236 */
- OP_FTREXEC, /* 237 */
- OP_FTEREAD, /* 238 */
- OP_FTEWRITE, /* 239 */
- OP_FTEEXEC, /* 240 */
- OP_FTIS, /* 241 */
- OP_FTEOWNED, /* 242 */
- OP_FTROWNED, /* 243 */
- OP_FTZERO, /* 244 */
- OP_FTSIZE, /* 245 */
- OP_FTMTIME, /* 246 */
- OP_FTATIME, /* 247 */
- OP_FTCTIME, /* 248 */
- OP_FTSOCK, /* 249 */
- OP_FTCHR, /* 250 */
- OP_FTBLK, /* 251 */
- OP_FTFILE, /* 252 */
- OP_FTDIR, /* 253 */
- OP_FTPIPE, /* 254 */
- OP_FTLINK, /* 255 */
- OP_FTSUID, /* 256 */
- OP_FTSGID, /* 257 */
- OP_FTSVTX, /* 258 */
- OP_FTTTY, /* 259 */
- OP_FTTEXT, /* 260 */
- OP_FTBINARY, /* 261 */
- OP_CHDIR, /* 262 */
- OP_CHOWN, /* 263 */
- OP_CHROOT, /* 264 */
- OP_UNLINK, /* 265 */
- OP_CHMOD, /* 266 */
- OP_UTIME, /* 267 */
- OP_RENAME, /* 268 */
- OP_LINK, /* 269 */
- OP_SYMLINK, /* 270 */
- OP_READLINK, /* 271 */
- OP_MKDIR, /* 272 */
- OP_RMDIR, /* 273 */
- OP_OPEN_DIR, /* 274 */
- OP_READDIR, /* 275 */
- OP_TELLDIR, /* 276 */
- OP_SEEKDIR, /* 277 */
- OP_REWINDDIR, /* 278 */
- OP_CLOSEDIR, /* 279 */
- OP_FORK, /* 280 */
- OP_WAIT, /* 281 */
- OP_WAITPID, /* 282 */
- OP_SYSTEM, /* 283 */
- OP_EXEC, /* 284 */
- OP_KILL, /* 285 */
- OP_GETPPID, /* 286 */
- OP_GETPGRP, /* 287 */
- OP_SETPGRP, /* 288 */
- OP_GETPRIORITY, /* 289 */
- OP_SETPRIORITY, /* 290 */
- OP_TIME, /* 291 */
- OP_TMS, /* 292 */
- OP_LOCALTIME, /* 293 */
- OP_GMTIME, /* 294 */
- OP_ALARM, /* 295 */
- OP_SLEEP, /* 296 */
- OP_SHMGET, /* 297 */
- OP_SHMCTL, /* 298 */
- OP_SHMREAD, /* 299 */
- OP_SHMWRITE, /* 300 */
- OP_MSGGET, /* 301 */
- OP_MSGCTL, /* 302 */
- OP_MSGSND, /* 303 */
- OP_MSGRCV, /* 304 */
- OP_SEMGET, /* 305 */
- OP_SEMCTL, /* 306 */
- OP_SEMOP, /* 307 */
- OP_REQUIRE, /* 308 */
- OP_DOFILE, /* 309 */
- OP_ENTEREVAL, /* 310 */
- OP_LEAVEEVAL, /* 311 */
- OP_ENTERTRY, /* 312 */
- OP_LEAVETRY, /* 313 */
- OP_GHBYNAME, /* 314 */
- OP_GHBYADDR, /* 315 */
- OP_GHOSTENT, /* 316 */
- OP_GNBYNAME, /* 317 */
- OP_GNBYADDR, /* 318 */
- OP_GNETENT, /* 319 */
- OP_GPBYNAME, /* 320 */
- OP_GPBYNUMBER, /* 321 */
- OP_GPROTOENT, /* 322 */
- OP_GSBYNAME, /* 323 */
- OP_GSBYPORT, /* 324 */
- OP_GSERVENT, /* 325 */
- OP_SHOSTENT, /* 326 */
- OP_SNETENT, /* 327 */
- OP_SPROTOENT, /* 328 */
- OP_SSERVENT, /* 329 */
- OP_EHOSTENT, /* 330 */
- OP_ENETENT, /* 331 */
- OP_EPROTOENT, /* 332 */
- OP_ESERVENT, /* 333 */
- OP_GPWNAM, /* 334 */
- OP_GPWUID, /* 335 */
- OP_GPWENT, /* 336 */
- OP_SPWENT, /* 337 */
- OP_EPWENT, /* 338 */
- OP_GGRNAM, /* 339 */
- OP_GGRGID, /* 340 */
- OP_GGRENT, /* 341 */
- OP_SGRENT, /* 342 */
- OP_EGRENT, /* 343 */
- OP_GETLOGIN, /* 344 */
- OP_SYSCALL, /* 345 */
- OP_LOCK, /* 346 */
- OP_THREADSV, /* 347 */
- OP_SETSTATE, /* 348 */
- OP_METHOD_NAMED,/* 349 */
+ OP_LEAVESUBLV, /* 168 */
+ OP_CALLER, /* 169 */
+ OP_WARN, /* 170 */
+ OP_DIE, /* 171 */
+ OP_RESET, /* 172 */
+ OP_LINESEQ, /* 173 */
+ OP_NEXTSTATE, /* 174 */
+ OP_DBSTATE, /* 175 */
+ OP_UNSTACK, /* 176 */
+ OP_ENTER, /* 177 */
+ OP_LEAVE, /* 178 */
+ OP_SCOPE, /* 179 */
+ OP_ENTERITER, /* 180 */
+ OP_ITER, /* 181 */
+ OP_ENTERLOOP, /* 182 */
+ OP_LEAVELOOP, /* 183 */
+ OP_RETURN, /* 184 */
+ OP_LAST, /* 185 */
+ OP_NEXT, /* 186 */
+ OP_REDO, /* 187 */
+ OP_DUMP, /* 188 */
+ OP_GOTO, /* 189 */
+ OP_EXIT, /* 190 */
+ OP_OPEN, /* 191 */
+ OP_CLOSE, /* 192 */
+ OP_PIPE_OP, /* 193 */
+ OP_FILENO, /* 194 */
+ OP_UMASK, /* 195 */
+ OP_BINMODE, /* 196 */
+ OP_TIE, /* 197 */
+ OP_UNTIE, /* 198 */
+ OP_TIED, /* 199 */
+ OP_DBMOPEN, /* 200 */
+ OP_DBMCLOSE, /* 201 */
+ OP_SSELECT, /* 202 */
+ OP_SELECT, /* 203 */
+ OP_GETC, /* 204 */
+ OP_READ, /* 205 */
+ OP_ENTERWRITE, /* 206 */
+ OP_LEAVEWRITE, /* 207 */
+ OP_PRTF, /* 208 */
+ OP_PRINT, /* 209 */
+ OP_SYSOPEN, /* 210 */
+ OP_SYSSEEK, /* 211 */
+ OP_SYSREAD, /* 212 */
+ OP_SYSWRITE, /* 213 */
+ OP_SEND, /* 214 */
+ OP_RECV, /* 215 */
+ OP_EOF, /* 216 */
+ OP_TELL, /* 217 */
+ OP_SEEK, /* 218 */
+ OP_TRUNCATE, /* 219 */
+ OP_FCNTL, /* 220 */
+ OP_IOCTL, /* 221 */
+ OP_FLOCK, /* 222 */
+ OP_SOCKET, /* 223 */
+ OP_SOCKPAIR, /* 224 */
+ OP_BIND, /* 225 */
+ OP_CONNECT, /* 226 */
+ OP_LISTEN, /* 227 */
+ OP_ACCEPT, /* 228 */
+ OP_SHUTDOWN, /* 229 */
+ OP_GSOCKOPT, /* 230 */
+ OP_SSOCKOPT, /* 231 */
+ OP_GETSOCKNAME, /* 232 */
+ OP_GETPEERNAME, /* 233 */
+ OP_LSTAT, /* 234 */
+ OP_STAT, /* 235 */
+ OP_FTRREAD, /* 236 */
+ OP_FTRWRITE, /* 237 */
+ OP_FTREXEC, /* 238 */
+ OP_FTEREAD, /* 239 */
+ OP_FTEWRITE, /* 240 */
+ OP_FTEEXEC, /* 241 */
+ OP_FTIS, /* 242 */
+ OP_FTEOWNED, /* 243 */
+ OP_FTROWNED, /* 244 */
+ OP_FTZERO, /* 245 */
+ OP_FTSIZE, /* 246 */
+ OP_FTMTIME, /* 247 */
+ OP_FTATIME, /* 248 */
+ OP_FTCTIME, /* 249 */
+ OP_FTSOCK, /* 250 */
+ OP_FTCHR, /* 251 */
+ OP_FTBLK, /* 252 */
+ OP_FTFILE, /* 253 */
+ OP_FTDIR, /* 254 */
+ OP_FTPIPE, /* 255 */
+ OP_FTLINK, /* 256 */
+ OP_FTSUID, /* 257 */
+ OP_FTSGID, /* 258 */
+ OP_FTSVTX, /* 259 */
+ OP_FTTTY, /* 260 */
+ OP_FTTEXT, /* 261 */
+ OP_FTBINARY, /* 262 */
+ OP_CHDIR, /* 263 */
+ OP_CHOWN, /* 264 */
+ OP_CHROOT, /* 265 */
+ OP_UNLINK, /* 266 */
+ OP_CHMOD, /* 267 */
+ OP_UTIME, /* 268 */
+ OP_RENAME, /* 269 */
+ OP_LINK, /* 270 */
+ OP_SYMLINK, /* 271 */
+ OP_READLINK, /* 272 */
+ OP_MKDIR, /* 273 */
+ OP_RMDIR, /* 274 */
+ OP_OPEN_DIR, /* 275 */
+ OP_READDIR, /* 276 */
+ OP_TELLDIR, /* 277 */
+ OP_SEEKDIR, /* 278 */
+ OP_REWINDDIR, /* 279 */
+ OP_CLOSEDIR, /* 280 */
+ OP_FORK, /* 281 */
+ OP_WAIT, /* 282 */
+ OP_WAITPID, /* 283 */
+ OP_SYSTEM, /* 284 */
+ OP_EXEC, /* 285 */
+ OP_KILL, /* 286 */
+ OP_GETPPID, /* 287 */
+ OP_GETPGRP, /* 288 */
+ OP_SETPGRP, /* 289 */
+ OP_GETPRIORITY, /* 290 */
+ OP_SETPRIORITY, /* 291 */
+ OP_TIME, /* 292 */
+ OP_TMS, /* 293 */
+ OP_LOCALTIME, /* 294 */
+ OP_GMTIME, /* 295 */
+ OP_ALARM, /* 296 */
+ OP_SLEEP, /* 297 */
+ OP_SHMGET, /* 298 */
+ OP_SHMCTL, /* 299 */
+ OP_SHMREAD, /* 300 */
+ OP_SHMWRITE, /* 301 */
+ OP_MSGGET, /* 302 */
+ OP_MSGCTL, /* 303 */
+ OP_MSGSND, /* 304 */
+ OP_MSGRCV, /* 305 */
+ OP_SEMGET, /* 306 */
+ OP_SEMCTL, /* 307 */
+ OP_SEMOP, /* 308 */
+ OP_REQUIRE, /* 309 */
+ OP_DOFILE, /* 310 */
+ OP_ENTEREVAL, /* 311 */
+ OP_LEAVEEVAL, /* 312 */
+ OP_ENTERTRY, /* 313 */
+ OP_LEAVETRY, /* 314 */
+ OP_GHBYNAME, /* 315 */
+ OP_GHBYADDR, /* 316 */
+ OP_GHOSTENT, /* 317 */
+ OP_GNBYNAME, /* 318 */
+ OP_GNBYADDR, /* 319 */
+ OP_GNETENT, /* 320 */
+ OP_GPBYNAME, /* 321 */
+ OP_GPBYNUMBER, /* 322 */
+ OP_GPROTOENT, /* 323 */
+ OP_GSBYNAME, /* 324 */
+ OP_GSBYPORT, /* 325 */
+ OP_GSERVENT, /* 326 */
+ OP_SHOSTENT, /* 327 */
+ OP_SNETENT, /* 328 */
+ OP_SPROTOENT, /* 329 */
+ OP_SSERVENT, /* 330 */
+ OP_EHOSTENT, /* 331 */
+ OP_ENETENT, /* 332 */
+ OP_EPROTOENT, /* 333 */
+ OP_ESERVENT, /* 334 */
+ OP_GPWNAM, /* 335 */
+ OP_GPWUID, /* 336 */
+ OP_GPWENT, /* 337 */
+ OP_SPWENT, /* 338 */
+ OP_EPWENT, /* 339 */
+ OP_GGRNAM, /* 340 */
+ OP_GGRGID, /* 341 */
+ OP_GGRENT, /* 342 */
+ OP_SGRENT, /* 343 */
+ OP_EGRENT, /* 344 */
+ OP_GETLOGIN, /* 345 */
+ OP_SYSCALL, /* 346 */
+ OP_LOCK, /* 347 */
+ OP_THREADSV, /* 348 */
+ OP_SETSTATE, /* 349 */
+ OP_METHOD_NAMED,/* 350 */
OP_max
} opcode;
-#define MAXO 350
+#define MAXO 351
return ((CPerlObj*)pPerl)->Perl_pp_leavesub();
}
+#undef Perl_pp_leavesublv
+OP *
+Perl_pp_leavesublv(pTHXo)
+{
+ return ((CPerlObj*)pPerl)->Perl_pp_leavesublv();
+}
+
#undef Perl_pp_leavetry
OP *
Perl_pp_leavetry(pTHXo)
(F) You aren't allowed to assign to the item indicated, or otherwise try to
change it, such as with an auto-increment.
+=item Can't modify non-lvalue subroutine call
+
+(F) Subroutines used in lvalue context should be marked as such, see
+L<perlsub/"Lvalue subroutines">.
+
=item Can't modify nonexistent substring
(P) The internal routine that does assignment to a substr() was handed
(F) The return statement was executed in mainline code, that is, where
there was no subroutine call to return out of. See L<perlsub>.
+=item Can't return %s from lvalue subroutine
+
+(F) Perl detected an attempt to return illegal lvalues (such
+as temporary or readonly values) from a subroutine used as an lvalue.
+This is not allowed.
+
=item Can't stat script "%s"
(P) For some reason you can't fstat() the script even though you have
(W) You tried to do a listen on a closed socket. Did you forget to check
the return value of your socket() call? See L<perlfunc/listen>.
+=item Lvalue subs returning %s not implemented yet
+
+(F) Due to limitations in the current implementation, array and hash
+values cannot be returned in subroutines used in lvalue context.
+See L<perlsub/"Lvalue subroutines">.
+
=item Method for operation %s not found in package %s during blessing
(F) An attempt was made to specify an entry in an overloading table that
The behavior of local() on non-existent members of composite
types is subject to change in future.
+=head2 Lvalue subroutines
+
+B<WARNING>: Lvalue subroutines are still experimental and the implementation
+may change in future versions of Perl.
+
+It is possible to return a modifiable value from a subroutine.
+To do this, you have to declare the subroutine to return an lvalue.
+
+ my $val;
+ sub canmod : lvalue {
+ $val;
+ }
+ sub nomod {
+ $val;
+ }
+
+ canmod() = 5; # assigns to $val
+ nomod() = 5; # ERROR
+
+The scalar/list context for the subroutine and for the right-hand
+side of assignment is determined as if the subroutine call is replaced
+by a scalar. For example, consider:
+
+ data(2,3) = get_data(3,4);
+
+Both subroutines here are called in a scalar context, while in:
+
+ (data(2,3)) = get_data(3,4);
+
+and in:
+
+ (data(2),data(3)) = get_data(3,4);
+
+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
if (cv) {
if (CvCLONE(cv))
cv = (CV*)sv_2mortal((SV*)cv_clone(cv));
+ if ((PL_op->op_private & OPpLVAL_INTRO) && !CvLVALUE(cv))
+ Perl_croak(aTHX_ "Can't modify non-lvalue subroutine call");
}
else
cv = (CV*)&PL_sv_undef;
Perl_pp_method
Perl_pp_entersub
Perl_pp_leavesub
+Perl_pp_leavesublv
Perl_pp_caller
Perl_pp_warn
Perl_pp_die
*MARK = SvREFCNT_inc(TOPs);
FREETMPS;
sv_2mortal(*MARK);
- } else {
+ }
+ else {
FREETMPS;
*MARK = sv_mortalcopy(TOPs);
}
- } else
+ }
+ else
*MARK = SvTEMP(TOPs) ? TOPs : sv_mortalcopy(TOPs);
- } else {
+ }
+ else {
MEXTEND(MARK, 0);
*MARK = &PL_sv_undef;
}
return pop_return();
}
+/* This duplicates the above code because the above code must not
+ * get any slower by more conditions */
+PP(pp_leavesublv)
+{
+ djSP;
+ SV **mark;
+ SV **newsp;
+ PMOP *newpm;
+ I32 gimme;
+ register PERL_CONTEXT *cx;
+ struct block_sub cxsub;
+
+ POPBLOCK(cx,newpm);
+ POPSUB1(cx); /* Delay POPSUB2 until stack values are safe */
+
+ TAINT_NOT;
+
+ if (cx->blk_sub.lval & OPpENTERSUB_INARGS) {
+ /* We are an argument to a function or grep().
+ * This kind of lvalueness was legal before lvalue
+ * subroutines too, so be backward compatible:
+ * cannot report errors. */
+
+ /* Scalar context *is* possible, on the LHS of -> only,
+ * as in f()->meth(). But this is not an lvalue. */
+ if (gimme == G_SCALAR)
+ goto temporise;
+ if (gimme == G_ARRAY) {
+ if (!CvLVALUE(cxsub.cv))
+ goto temporise_array;
+ EXTEND_MORTAL(SP - newsp);
+ for (mark = newsp + 1; mark <= SP; mark++) {
+ if (SvTEMP(*mark))
+ /* empty */ ;
+ else if (SvFLAGS(*mark) & (SVs_PADTMP | SVf_READONLY))
+ *mark = sv_mortalcopy(*mark);
+ else {
+ /* Can be a localized value subject to deletion. */
+ PL_tmps_stack[++PL_tmps_ix] = *mark;
+ SvREFCNT_inc(*mark);
+ }
+ }
+ }
+ }
+ else if (cx->blk_sub.lval) { /* Leave it as it is if we can. */
+ /* Here we go for robustness, not for speed, so we change all
+ * the refcounts so the caller gets a live guy. Cannot set
+ * TEMP, so sv_2mortal is out of question. */
+ if (!CvLVALUE(cxsub.cv))
+ Perl_croak(aTHX_ "Can't modify non-lvalue subroutine call");
+ if (gimme == G_SCALAR) {
+ MARK = newsp + 1;
+ EXTEND_MORTAL(1);
+ if (MARK == SP) {
+ if (SvFLAGS(TOPs) & (SVs_TEMP | SVs_PADTMP | SVf_READONLY))
+ Perl_croak(aTHX_ "Can't return a %s from lvalue subroutine",
+ SvREADONLY(TOPs) ? "readonly value" : "temporary");
+ else { /* Can be a localized value
+ * subject to deletion. */
+ PL_tmps_stack[++PL_tmps_ix] = *mark;
+ SvREFCNT_inc(*mark);
+ }
+ }
+ else /* Should not happen? */
+ Perl_croak(aTHX_ "%s returned from lvalue subroutine in scalar context",
+ (MARK > SP ? "Empty array" : "Array"));
+ SP = MARK;
+ }
+ else if (gimme == G_ARRAY) {
+ EXTEND_MORTAL(SP - newsp);
+ for (mark = newsp + 1; mark <= SP; mark++) {
+ if (SvFLAGS(*mark) & (SVs_TEMP | SVs_PADTMP | SVf_READONLY))
+ /* Might be flattened array after $#array = */
+ Perl_croak(aTHX_ "Can't return %s from lvalue subroutine",
+ (*mark != &PL_sv_undef)
+ ? (SvREADONLY(TOPs)
+ ? "a readonly value" : "a temporary")
+ : "an uninitialized value");
+ else {
+ mortalize:
+ /* Can be a localized value subject to deletion. */
+ PL_tmps_stack[++PL_tmps_ix] = *mark;
+ SvREFCNT_inc(*mark);
+ }
+ }
+ }
+ }
+ else {
+ if (gimme == G_SCALAR) {
+ temporise:
+ MARK = newsp + 1;
+ if (MARK <= SP) {
+ if (cxsub.cv && CvDEPTH(cxsub.cv) > 1) {
+ if (SvTEMP(TOPs)) {
+ *MARK = SvREFCNT_inc(TOPs);
+ FREETMPS;
+ sv_2mortal(*MARK);
+ }
+ else {
+ FREETMPS;
+ *MARK = sv_mortalcopy(TOPs);
+ }
+ }
+ else
+ *MARK = SvTEMP(TOPs) ? TOPs : sv_mortalcopy(TOPs);
+ }
+ else {
+ MEXTEND(MARK, 0);
+ *MARK = &PL_sv_undef;
+ }
+ SP = MARK;
+ }
+ else if (gimme == G_ARRAY) {
+ temporise_array:
+ for (MARK = newsp + 1; MARK <= SP; MARK++) {
+ if (!SvTEMP(*MARK)) {
+ *MARK = sv_mortalcopy(*MARK);
+ TAINT_NOT; /* Each item is independent */
+ }
+ }
+ }
+ }
+ PUTBACK;
+
+ POPSUB2(); /* Stack values are safe: release CV and @_ ... */
+ PL_curpm = newpm; /* ... and pop $1 et al */
+
+ LEAVE;
+ return pop_return();
+}
+
+
STATIC CV *
S_get_db_sub(pTHX_ SV **svp, CV *cv)
{
"entersub: %p grabbing %p:%s in stash %s\n",
thr, cv, SvPEEK((SV*)cv), CvSTASH(cv) ?
HvNAME(CvSTASH(cv)) : "(none)"));
- } else {
+ }
+ else {
/* Make a new clone. */
CV *clonecv;
SvREFCNT_inc(cv); /* don't let it vanish from under us */
PERL_PPDEF(Perl_pp_method)
PERL_PPDEF(Perl_pp_entersub)
PERL_PPDEF(Perl_pp_leavesub)
+PERL_PPDEF(Perl_pp_leavesublv)
PERL_PPDEF(Perl_pp_caller)
PERL_PPDEF(Perl_pp_warn)
PERL_PPDEF(Perl_pp_die)
--- /dev/null
+print "1..46\n";
+
+BEGIN {
+ chdir 't' if -d 't';
+ unshift @INC, '../lib';
+}
+
+sub a {use attrs 'lvalue'; my $a = 34; bless \$a} # Return a temporary
+sub b {use attrs 'lvalue'; shift}
+
+my $out = a(b()); # Check that temporaries are allowed.
+print "# `$out'\nnot " unless ref $out eq 'main'; # Not reached if error.
+print "ok 1\n";
+
+my @out = grep /main/, a(b()); # Check that temporaries are allowed.
+print "# `@out'\nnot " unless @out==1; # Not reached if error.
+print "ok 2\n";
+
+my $in;
+
+# Check that we can return localized values from subroutines:
+
+sub in {use attrs 'lvalue'; $in = shift;}
+sub neg {use attrs 'lvalue'; #(num_str) return num_str
+ local $_ = shift;
+ s/^\+/-/;
+ $_;
+}
+in(neg("+2"));
+
+
+print "# `$in'\nnot " unless $in eq '-2';
+print "ok 3\n";
+
+sub get_lex {use attrs 'lvalue'; $in}
+sub get_st {use attrs 'lvalue'; $blah}
+sub id {use attrs 'lvalue'; shift}
+sub id1 {use attrs 'lvalue'; $_[0]}
+sub inc {use attrs 'lvalue'; ++$_[0]}
+
+$in = 5;
+$blah = 3;
+
+get_st = 7;
+
+print "# `$blah' ne 7\nnot " unless $blah eq 7;
+print "ok 4\n";
+
+get_lex = 7;
+
+print "# `$in' ne 7\nnot " unless $in eq 7;
+print "ok 5\n";
+
+++get_st;
+
+print "# `$blah' ne 8\nnot " unless $blah eq 8;
+print "ok 6\n";
+
+++get_lex;
+
+print "# `$in' ne 8\nnot " unless $in eq 8;
+print "ok 7\n";
+
+id(get_st) = 10;
+
+print "# `$blah' ne 10\nnot " unless $blah eq 10;
+print "ok 8\n";
+
+id(get_lex) = 10;
+
+print "# `$in' ne 10\nnot " unless $in eq 10;
+print "ok 9\n";
+
+++id(get_st);
+
+print "# `$blah' ne 11\nnot " unless $blah eq 11;
+print "ok 10\n";
+
+++id(get_lex);
+
+print "# `$in' ne 11\nnot " unless $in eq 11;
+print "ok 11\n";
+
+id1(get_st) = 20;
+
+print "# `$blah' ne 20\nnot " unless $blah eq 20;
+print "ok 12\n";
+
+id1(get_lex) = 20;
+
+print "# `$in' ne 20\nnot " unless $in eq 20;
+print "ok 13\n";
+
+++id1(get_st);
+
+print "# `$blah' ne 21\nnot " unless $blah eq 21;
+print "ok 14\n";
+
+++id1(get_lex);
+
+print "# `$in' ne 21\nnot " unless $in eq 21;
+print "ok 15\n";
+
+inc(get_st);
+
+print "# `$blah' ne 22\nnot " unless $blah eq 22;
+print "ok 16\n";
+
+inc(get_lex);
+
+print "# `$in' ne 22\nnot " unless $in eq 22;
+print "ok 17\n";
+
+inc(id(get_st));
+
+print "# `$blah' ne 23\nnot " unless $blah eq 23;
+print "ok 18\n";
+
+inc(id(get_lex));
+
+print "# `$in' ne 23\nnot " unless $in eq 23;
+print "ok 19\n";
+
+++inc(id1(id(get_st)));
+
+print "# `$blah' ne 25\nnot " unless $blah eq 25;
+print "ok 20\n";
+
+++inc(id1(id(get_lex)));
+
+print "# `$in' ne 25\nnot " unless $in eq 25;
+print "ok 21\n";
+
+@a = (1) x 3;
+@b = (undef) x 2;
+$#c = 3; # These slots are not fillable.
+
+# Explanation: empty slots contain &sv_undef.
+
+=for disabled constructs
+
+sub a3 {use attrs 'lvalue'; @a}
+sub b2 {use attrs 'lvalue'; @b}
+sub c4 {use attrs 'lvalue'; @c}
+
+$_ = '';
+
+eval <<'EOE' or $_ = $@;
+ ($x, a3, $y, b2, $z, c4, $t) = (34 .. 78);
+ 1;
+EOE
+
+#@out = ($x, a3, $y, b2, $z, c4, $t);
+#@in = (34 .. 41, (undef) x 4, 46);
+#print "# `@out' ne `@in'\nnot " unless "@out" eq "@in";
+
+print "# '$_'.\nnot "
+ unless /Can\'t return an uninitialized value from lvalue subroutine/;
+=cut
+
+print "ok 22\n";
+
+my $var;
+
+sub a::var {use attrs 'lvalue'; $var}
+
+"a"->var = 45;
+
+print "# `$var' ne 45\nnot " unless $var eq 45;
+print "ok 23\n";
+
+my $oo;
+$o = bless \$oo, "a";
+
+$o->var = 47;
+
+print "# `$var' ne 47\nnot " unless $var eq 47;
+print "ok 24\n";
+
+sub o {use attrs 'lvalue'; $o}
+
+o->var = 49;
+
+print "# `$var' ne 49\nnot " unless $var eq 49;
+print "ok 25\n";
+
+sub nolv () { $x0, $x1 } # Not lvalue
+
+$_ = '';
+
+eval <<'EOE' or $_ = $@;
+ nolv = (2,3);
+ 1;
+EOE
+
+print "not "
+ unless /Can\'t modify non-lvalue subroutine call in scalar assignment/;
+print "ok 26\n";
+
+$_ = '';
+
+eval <<'EOE' or $_ = $@;
+ nolv = (2,3) if $_;
+ 1;
+EOE
+
+print "not "
+ unless /Can\'t modify non-lvalue subroutine call in scalar assignment/;
+print "ok 27\n";
+
+$_ = '';
+
+eval <<'EOE' or $_ = $@;
+ &nolv = (2,3) if $_;
+ 1;
+EOE
+
+print "not "
+ unless /Can\'t modify non-lvalue subroutine call in scalar assignment/;
+print "ok 28\n";
+
+$x0 = $x1 = $_ = undef;
+$nolv = \&nolv;
+
+eval <<'EOE' or $_ = $@;
+ $nolv->() = (2,3) if $_;
+ 1;
+EOE
+
+print "# '$_', '$x0', '$x1'.\nnot " if defined $_;
+print "ok 29\n";
+
+$x0 = $x1 = $_ = undef;
+$nolv = \&nolv;
+
+eval <<'EOE' or $_ = $@;
+ $nolv->() = (2,3);
+ 1;
+EOE
+
+print "# '$_', '$x0', '$x1'.\nnot "
+ unless /Can\'t modify non-lvalue indirect subroutine call/;
+print "ok 30\n";
+
+sub lv0 {use attrs 'lvalue';} # Converted to lv10 in scalar context
+
+$_ = undef;
+eval <<'EOE' or $_ = $@;
+ lv0 = (2,3);
+ 1;
+EOE
+
+print "# '$_'.\nnot "
+ unless /Can\'t return a readonly value from lvalue subroutine/;
+print "ok 31\n";
+
+sub lv10 {use attrs 'lvalue';}
+
+$_ = undef;
+eval <<'EOE' or $_ = $@;
+ (lv0) = (2,3);
+ 1;
+EOE
+
+print "# '$_'.\nnot " if defined $_;
+print "ok 32\n";
+
+sub lv1u {use attrs 'lvalue'; undef }
+
+$_ = undef;
+eval <<'EOE' or $_ = $@;
+ lv1u = (2,3);
+ 1;
+EOE
+
+print "# '$_'.\nnot "
+ unless /Can\'t return a readonly value from lvalue subroutine/;
+print "ok 33\n";
+
+$_ = undef;
+eval <<'EOE' or $_ = $@;
+ (lv1u) = (2,3);
+ 1;
+EOE
+
+print "# '$_'.\nnot "
+ unless /Can\'t return an uninitialized value from lvalue subroutine/;
+print "ok 34\n";
+
+$x = '1234567';
+sub lv1t {use attrs 'lvalue'; index $x, 2 }
+
+$_ = undef;
+eval <<'EOE' or $_ = $@;
+ lv1t = (2,3);
+ 1;
+EOE
+
+print "# '$_'.\nnot "
+ unless /Can\'t return a temporary from lvalue subroutine/;
+print "ok 35\n";
+
+$_ = undef;
+eval <<'EOE' or $_ = $@;
+ (lv1t) = (2,3);
+ 1;
+EOE
+
+print "# '$_'.\nnot "
+ unless /Can\'t return a temporary from lvalue subroutine/;
+print "ok 36\n";
+
+$xxx = 'xxx';
+sub xxx () { $xxx } # Not lvalue
+sub lv1tmp {use attrs 'lvalue'; xxx } # is it a TEMP?
+
+$_ = undef;
+eval <<'EOE' or $_ = $@;
+ lv1tmp = (2,3);
+ 1;
+EOE
+
+print "# '$_'.\nnot "
+ unless /Can\'t return a temporary from lvalue subroutine/;
+print "ok 37\n";
+
+$_ = undef;
+eval <<'EOE' or $_ = $@;
+ (lv1tmp) = (2,3);
+ 1;
+EOE
+
+print "# '$_'.\nnot "
+ unless /Can\'t return a temporary from lvalue subroutine/;
+print "ok 38\n";
+
+sub xxx () { 'xxx' } # Not lvalue
+sub lv1tmpr {use attrs 'lvalue'; xxx } # is it a TEMP?
+
+$_ = undef;
+eval <<'EOE' or $_ = $@;
+ lv1tmpr = (2,3);
+ 1;
+EOE
+
+print "# '$_'.\nnot "
+ unless /Can\'t return a readonly value from lvalue subroutine/;
+print "ok 39\n";
+
+$_ = undef;
+eval <<'EOE' or $_ = $@;
+ (lv1tmpr) = (2,3);
+ 1;
+EOE
+
+print "# '$_'.\nnot "
+ unless /Can\'t return a readonly value from lvalue subroutine/;
+print "ok 40\n";
+
+=for disabled constructs
+
+sub lva {use attrs 'lvalue';@a}
+
+$_ = undef;
+@a = ();
+$a[1] = 12;
+eval <<'EOE' or $_ = $@;
+ (lva) = (2,3);
+ 1;
+EOE
+
+print "# '$_'.\nnot "
+ unless /Can\'t return an uninitialized value from lvalue subroutine/;
+print "ok 41\n";
+
+$_ = undef;
+@a = ();
+$a[0] = undef;
+$a[1] = 12;
+eval <<'EOE' or $_ = $@;
+ (lva) = (2,3);
+ 1;
+EOE
+
+print "# '$_'.\nnot " unless "'@a' $_" eq "'2 3' ";
+print "ok 42\n";
+
+$_ = undef;
+@a = ();
+$a[0] = undef;
+$a[1] = 12;
+eval <<'EOE' or $_ = $@;
+ (lva) = (2,3);
+ 1;
+EOE
+
+print "# '$_'.\nnot " unless "'@a' $_" eq "'2 3' ";
+print "ok 43\n";
+
+=cut
+
+print "ok $_\n" for 41..43;
+
+sub lv1n {use attrs 'lvalue'; $newvar }
+
+$_ = undef;
+eval <<'EOE' or $_ = $@;
+ lv1n = (3,4);
+ 1;
+EOE
+
+print "# '$_', '$newvar'.\nnot " unless "'$newvar' $_" eq "'4' ";
+print "ok 44\n";
+
+sub lv1nn {use attrs 'lvalue'; $nnewvar }
+
+$_ = undef;
+eval <<'EOE' or $_ = $@;
+ (lv1nn) = (3,4);
+ 1;
+EOE
+
+print "# '$_'.\nnot " unless "'$nnewvar' $_" eq "'3' ";
+print "ok 45\n";
+
+$a = \&lv1nn;
+$a->() = 8;
+print "# '$nnewvar'.\nnot " unless $nnewvar eq '8';
+print "ok 46\n";
Deep recursion on subroutine \"%s\"
sub fred
{
- goto &fred() if $a++ < 200
+ fred() if $a++ < 200
}
- goto &fred()
+ fred()
(in cleanup) foo bar
package Foo;
BEGIN { warn "PREFIX\n" ;}
sub fred
{
- goto &fred() if $a++ < 200
+ fred() if $a++ < 200
}
-goto &fred()
+fred()
EXPECT
Deep recursion on subroutine "main::fred" at - line 6.
########
BEGIN { warn "PREFIX\n" ;}
sub fred
{
- goto &fred() if $a++ < 200
+ fred() if $a++ < 200
}
-goto &fred()
+fred()
EXPECT
-Can't find label
########
# pp_ctl.c
use warnings 'unsafe' ;
projects / p5sagit/p5-mst-13.2.git / commitdiff