From: Gurusamy Sarathy Date: Sun, 5 Sep 1999 22:07:18 +0000 (+0000) Subject: initial implementation of lvalue subroutines (slightly fixed X-Git-Tag: accepted/trunk/20130322.191538~36119 X-Git-Url: http://review.tizen.org/git/?a=commitdiff_plain;h=cd06dffe59d60ee6a2fdd7c81f8cef42c7026b36;p=platform%2Fupstream%2Fperl.git initial implementation of lvalue subroutines (slightly fixed version of patch suggested by Ilya Zakharevich, which in turn is based on the one suggested by Tuomas J. Lukka ) p4raw-id: //depot/perl@4081 --- diff --git a/MANIFEST b/MANIFEST index f5ea95c..6bd774f 100644 --- a/MANIFEST +++ b/MANIFEST @@ -1345,6 +1345,7 @@ t/pragma/strict-subs Tests of "use strict 'subs'" for strict.t 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 diff --git a/cop.h b/cop.h index f23251b..d0a59a0 100644 --- a/cop.h +++ b/cop.h @@ -35,12 +35,15 @@ struct block_sub { 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; \ diff --git a/cv.h b/cv.h index 7042708..67d4a8e 100644 --- a/cv.h +++ b/cv.h @@ -62,6 +62,7 @@ struct xpvcv { (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) @@ -97,6 +98,10 @@ struct xpvcv { #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) diff --git a/dump.c b/dump.c index 0e7de38..1ec22f2 100644 --- a/dump.c +++ b/dump.c @@ -509,6 +509,9 @@ Perl_do_op_dump(pTHX_ I32 level, PerlIO *file, OP *o) 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"); diff --git a/embed.h b/embed.h index 1d33518..21f5f36 100644 --- a/embed.h +++ b/embed.h @@ -1212,6 +1212,7 @@ #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 @@ -2538,6 +2539,7 @@ #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) @@ -4959,6 +4961,8 @@ #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 diff --git a/ext/Opcode/Opcode.pm b/ext/Opcode/Opcode.pm index 38c8e65..ff3899f 100644 --- a/ext/Opcode/Opcode.pm +++ b/ext/Opcode/Opcode.pm @@ -336,7 +336,7 @@ invert_opset function. 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 diff --git a/ext/attrs/attrs.pm b/ext/attrs/attrs.pm index fe2bf35..e97fa1e 100644 --- a/ext/attrs/attrs.pm +++ b/ext/attrs/attrs.pm @@ -46,6 +46,11 @@ execution. The semantics of the lock are exactly those of one explicitly taken with the C operator immediately after the subroutine is entered. +=item lvalue + +Setting this attribute enables the subroutine to be used in +lvalue context. See L. + =back =cut diff --git a/ext/attrs/attrs.xs b/ext/attrs/attrs.xs index 53ba535..a92922d 100644 --- a/ext/attrs/attrs.xs +++ b/ext/attrs/attrs.xs @@ -10,6 +10,8 @@ get_flag(char *attr) return CVf_METHOD; else if (strnEQ(attr, "locked", 6)) return CVf_LOCKED; + else if (strnEQ(attr, "lvalue", 6)) + return CVf_LVALUE; else return 0; } diff --git a/objXSUB.h b/objXSUB.h index e7b34b1..abb9f39 100644 --- a/objXSUB.h +++ b/objXSUB.h @@ -4406,6 +4406,10 @@ #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 diff --git a/op.c b/op.c index 57ff104..ae477d8 100644 --- a/op.c +++ b/op.c @@ -1239,6 +1239,91 @@ Perl_mod(pTHX_ OP *o, I32 type) 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: @@ -1247,7 +1332,10 @@ Perl_mod(pTHX_ OP *o, I32 type) 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; @@ -4207,7 +4295,12 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) } } - 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)); @@ -5825,6 +5918,7 @@ Perl_peep(pTHX_ register OP *o) dTHR; register OP* oldop = 0; STRLEN n_a; + OP *last_composite = Nullop; if (!o || o->op_seq) return; @@ -5843,6 +5937,7 @@ 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: @@ -5871,7 +5966,8 @@ Perl_peep(pTHX_ register OP *o) && (((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; } @@ -6040,6 +6136,40 @@ 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->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 d1e2f27..c6938c9 100644 --- a/op.h +++ b/op.h @@ -92,7 +92,7 @@ typedef U32 PADOFFSET; : 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. */ @@ -128,6 +128,7 @@ typedef U32 PADOFFSET; /* 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 */ diff --git a/opcode.h b/opcode.h index abd180c..7ca8d48 100644 --- a/opcode.h +++ b/opcode.h @@ -183,6 +183,7 @@ EXT char *PL_op_name[] = { "method", "entersub", "leavesub", + "leavesublv", "caller", "warn", "die", @@ -540,6 +541,7 @@ EXT char *PL_op_desc[] = { "method lookup", "subroutine entry", "subroutine exit", + "lvalue subroutine exit", "caller", "warn", "die", @@ -902,6 +904,7 @@ EXT OP * (CPERLscope(*PL_ppaddr)[])(pTHX) = { Perl_pp_method, Perl_pp_entersub, Perl_pp_leavesub, + Perl_pp_leavesublv, Perl_pp_caller, Perl_pp_warn, Perl_pp_die, @@ -1259,6 +1262,7 @@ EXT OP * (CPERLscope(*PL_check)[]) (pTHX_ OP *op) = { 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 */ @@ -1616,6 +1620,7 @@ EXT U32 PL_opargs[] = { 0x00000240, /* method */ 0x00004249, /* entersub */ 0x00000200, /* leavesub */ + 0x00000200, /* leavesublv */ 0x00013608, /* caller */ 0x0000481d, /* warn */ 0x0000485d, /* die */ diff --git a/opcode.pl b/opcode.pl index f112745..5b666d3 100755 --- a/opcode.pl +++ b/opcode.pl @@ -549,6 +549,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 caller caller ck_fun t% S? warn warn ck_fun imst@ L die die ck_fun dimst@ L diff --git a/opnames.h b/opnames.h index 417d74d..e9f8b4f 100644 --- a/opnames.h +++ b/opnames.h @@ -172,190 +172,191 @@ typedef enum opcode { 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 diff --git a/perlapi.c b/perlapi.c index 1945146..6860b18 100644 --- a/perlapi.c +++ b/perlapi.c @@ -6304,6 +6304,13 @@ Perl_pp_leavesub(pTHXo) 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) diff --git a/pod/perldiag.pod b/pod/perldiag.pod index 60a901e..10808ff 100644 --- a/pod/perldiag.pod +++ b/pod/perldiag.pod @@ -866,6 +866,11 @@ to exist. (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. + =item Can't modify nonexistent substring (P) The internal routine that does assignment to a substr() was handed @@ -950,6 +955,12 @@ of suidperl. (F) The return statement was executed in mainline code, that is, where there was no subroutine call to return out of. See L. +=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 @@ -1713,6 +1724,12 @@ effective uids or gids failed. (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. +=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. + =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 diff --git a/pod/perlsub.pod b/pod/perlsub.pod index 47f507f..2beb3de 100644 --- a/pod/perlsub.pod +++ b/pod/perlsub.pod @@ -611,6 +611,45 @@ Perl will print The behavior of local() on non-existent members of composite types is subject to change in future. +=head2 Lvalue subroutines + +B: 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: The mechanism described in this section was originally diff --git a/pp.c b/pp.c index cde539c..4d96370 100644 --- a/pp.c +++ b/pp.c @@ -375,6 +375,8 @@ 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)) + Perl_croak(aTHX_ "Can't modify non-lvalue subroutine call"); } else cv = (CV*)&PL_sv_undef; diff --git a/pp.sym b/pp.sym index cbbbaae..c0a8e91 100644 --- a/pp.sym +++ b/pp.sym @@ -203,6 +203,7 @@ Perl_pp_orassign Perl_pp_method Perl_pp_entersub Perl_pp_leavesub +Perl_pp_leavesublv Perl_pp_caller Perl_pp_warn Perl_pp_die diff --git a/pp_hot.c b/pp_hot.c index 78f07a1..bb034e5 100644 --- a/pp_hot.c +++ b/pp_hot.c @@ -1921,13 +1921,16 @@ PP(pp_leavesub) *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; } @@ -1950,6 +1953,138 @@ PP(pp_leavesub) 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) { @@ -2193,7 +2328,8 @@ try_autoload: "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 */ diff --git a/pp_proto.h b/pp_proto.h index 5c3d301..44f1658 100644 --- a/pp_proto.h +++ b/pp_proto.h @@ -204,6 +204,7 @@ PERL_PPDEF(Perl_pp_orassign) 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) diff --git a/t/pragma/sub_lval.t b/t/pragma/sub_lval.t new file mode 100755 index 0000000..f6d867c --- /dev/null +++ b/t/pragma/sub_lval.t @@ -0,0 +1,429 @@ +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"; diff --git a/t/pragma/warn/pp_ctl b/t/pragma/warn/pp_ctl index 5e0dd27..70e6d60 100644 --- a/t/pragma/warn/pp_ctl +++ b/t/pragma/warn/pp_ctl @@ -48,10 +48,10 @@ 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; @@ -179,10 +179,10 @@ use warnings 'recursion' ; 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. ######## @@ -191,12 +191,11 @@ no warnings 'recursion' ; 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' ;