This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Abstract the specific use of SvCUR in GVs for detecting variables on
[perl5.git] / op.c
CommitLineData
a0d0e21e 1/* op.c
79072805 2 *
4bb101f2 3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
acde74e1 4 * 2000, 2001, 2002, 2003, 2004, 2005, 2006, by Larry Wall and others
79072805
LW
5 *
6 * You may distribute under the terms of either the GNU General Public
7 * License or the Artistic License, as specified in the README file.
8 *
a0d0e21e
LW
9 */
10
11/*
12 * "You see: Mr. Drogo, he married poor Miss Primula Brandybuck. She was
13 * our Mr. Bilbo's first cousin on the mother's side (her mother being the
14 * youngest of the Old Took's daughters); and Mr. Drogo was his second
15 * cousin. So Mr. Frodo is his first *and* second cousin, once removed
16 * either way, as the saying is, if you follow me." --the Gaffer
79072805
LW
17 */
18
166f8a29
DM
19/* This file contains the functions that create, manipulate and optimize
20 * the OP structures that hold a compiled perl program.
21 *
22 * A Perl program is compiled into a tree of OPs. Each op contains
23 * structural pointers (eg to its siblings and the next op in the
24 * execution sequence), a pointer to the function that would execute the
25 * op, plus any data specific to that op. For example, an OP_CONST op
26 * points to the pp_const() function and to an SV containing the constant
27 * value. When pp_const() is executed, its job is to push that SV onto the
28 * stack.
29 *
30 * OPs are mainly created by the newFOO() functions, which are mainly
31 * called from the parser (in perly.y) as the code is parsed. For example
32 * the Perl code $a + $b * $c would cause the equivalent of the following
33 * to be called (oversimplifying a bit):
34 *
35 * newBINOP(OP_ADD, flags,
36 * newSVREF($a),
37 * newBINOP(OP_MULTIPLY, flags, newSVREF($b), newSVREF($c))
38 * )
39 *
40 * Note that during the build of miniperl, a temporary copy of this file
41 * is made, called opmini.c.
42 */
ccfc67b7 43
61b743bb
DM
44/*
45Perl's compiler is essentially a 3-pass compiler with interleaved phases:
46
47 A bottom-up pass
48 A top-down pass
49 An execution-order pass
50
51The bottom-up pass is represented by all the "newOP" routines and
52the ck_ routines. The bottom-upness is actually driven by yacc.
53So at the point that a ck_ routine fires, we have no idea what the
54context is, either upward in the syntax tree, or either forward or
55backward in the execution order. (The bottom-up parser builds that
56part of the execution order it knows about, but if you follow the "next"
57links around, you'll find it's actually a closed loop through the
58top level node.
59
60Whenever the bottom-up parser gets to a node that supplies context to
61its components, it invokes that portion of the top-down pass that applies
62to that part of the subtree (and marks the top node as processed, so
63if a node further up supplies context, it doesn't have to take the
64plunge again). As a particular subcase of this, as the new node is
65built, it takes all the closed execution loops of its subcomponents
66and links them into a new closed loop for the higher level node. But
67it's still not the real execution order.
68
69The actual execution order is not known till we get a grammar reduction
70to a top-level unit like a subroutine or file that will be called by
71"name" rather than via a "next" pointer. At that point, we can call
72into peep() to do that code's portion of the 3rd pass. It has to be
73recursive, but it's recursive on basic blocks, not on tree nodes.
74*/
75
79072805 76#include "EXTERN.h"
864dbfa3 77#define PERL_IN_OP_C
79072805 78#include "perl.h"
77ca0c92 79#include "keywords.h"
79072805 80
a07e034d 81#define CALL_PEEP(o) CALL_FPTR(PL_peepp)(aTHX_ o)
a2efc822 82
238a4c30
NIS
83#if defined(PL_OP_SLAB_ALLOC)
84
85#ifndef PERL_SLAB_SIZE
86#define PERL_SLAB_SIZE 2048
87#endif
88
c7e45529
AE
89void *
90Perl_Slab_Alloc(pTHX_ int m, size_t sz)
1c846c1f 91{
5a8e194f
NIS
92 /*
93 * To make incrementing use count easy PL_OpSlab is an I32 *
94 * To make inserting the link to slab PL_OpPtr is I32 **
95 * So compute size in units of sizeof(I32 *) as that is how Pl_OpPtr increments
96 * Add an overhead for pointer to slab and round up as a number of pointers
97 */
98 sz = (sz + 2*sizeof(I32 *) -1)/sizeof(I32 *);
238a4c30 99 if ((PL_OpSpace -= sz) < 0) {
083fcd59
JH
100 PL_OpPtr = (I32 **) PerlMemShared_malloc(PERL_SLAB_SIZE*sizeof(I32*));
101 if (!PL_OpPtr) {
238a4c30
NIS
102 return NULL;
103 }
5a8e194f
NIS
104 Zero(PL_OpPtr,PERL_SLAB_SIZE,I32 **);
105 /* We reserve the 0'th I32 sized chunk as a use count */
106 PL_OpSlab = (I32 *) PL_OpPtr;
107 /* Reduce size by the use count word, and by the size we need.
108 * Latter is to mimic the '-=' in the if() above
109 */
110 PL_OpSpace = PERL_SLAB_SIZE - (sizeof(I32)+sizeof(I32 **)-1)/sizeof(I32 **) - sz;
238a4c30
NIS
111 /* Allocation pointer starts at the top.
112 Theory: because we build leaves before trunk allocating at end
113 means that at run time access is cache friendly upward
114 */
5a8e194f 115 PL_OpPtr += PERL_SLAB_SIZE;
238a4c30
NIS
116 }
117 assert( PL_OpSpace >= 0 );
118 /* Move the allocation pointer down */
119 PL_OpPtr -= sz;
5a8e194f 120 assert( PL_OpPtr > (I32 **) PL_OpSlab );
238a4c30
NIS
121 *PL_OpPtr = PL_OpSlab; /* Note which slab it belongs to */
122 (*PL_OpSlab)++; /* Increment use count of slab */
5a8e194f 123 assert( PL_OpPtr+sz <= ((I32 **) PL_OpSlab + PERL_SLAB_SIZE) );
238a4c30
NIS
124 assert( *PL_OpSlab > 0 );
125 return (void *)(PL_OpPtr + 1);
126}
127
c7e45529
AE
128void
129Perl_Slab_Free(pTHX_ void *op)
238a4c30 130{
551405c4 131 I32 * const * const ptr = (I32 **) op;
aec46f14 132 I32 * const slab = ptr[-1];
5a8e194f
NIS
133 assert( ptr-1 > (I32 **) slab );
134 assert( ptr < ( (I32 **) slab + PERL_SLAB_SIZE) );
238a4c30
NIS
135 assert( *slab > 0 );
136 if (--(*slab) == 0) {
7e4e8c89
NC
137# ifdef NETWARE
138# define PerlMemShared PerlMem
139# endif
083fcd59
JH
140
141 PerlMemShared_free(slab);
238a4c30
NIS
142 if (slab == PL_OpSlab) {
143 PL_OpSpace = 0;
144 }
145 }
b7dc083c 146}
b7dc083c 147#endif
e50aee73 148/*
ce6f1cbc 149 * In the following definition, the ", (OP*)0" is just to make the compiler
a5f75d66 150 * think the expression is of the right type: croak actually does a Siglongjmp.
e50aee73 151 */
11343788 152#define CHECKOP(type,o) \
ce6f1cbc 153 ((PL_op_mask && PL_op_mask[type]) \
5dc0d613 154 ? ( op_free((OP*)o), \
cb77fdf0 155 Perl_croak(aTHX_ "'%s' trapped by operation mask", PL_op_desc[type]), \
ce6f1cbc 156 (OP*)0 ) \
fc0dc3b3 157 : CALL_FPTR(PL_check[type])(aTHX_ (OP*)o))
e50aee73 158
e6438c1a 159#define RETURN_UNLIMITED_NUMBER (PERL_INT_MAX / 2)
c53d7c7d 160
8b6b16e7 161STATIC const char*
cea2e8a9 162S_gv_ename(pTHX_ GV *gv)
4633a7c4 163{
46c461b5 164 SV* const tmpsv = sv_newmortal();
bd61b366 165 gv_efullname3(tmpsv, gv, NULL);
8b6b16e7 166 return SvPV_nolen_const(tmpsv);
4633a7c4
LW
167}
168
76e3520e 169STATIC OP *
cea2e8a9 170S_no_fh_allowed(pTHX_ OP *o)
79072805 171{
cea2e8a9 172 yyerror(Perl_form(aTHX_ "Missing comma after first argument to %s function",
53e06cf0 173 OP_DESC(o)));
11343788 174 return o;
79072805
LW
175}
176
76e3520e 177STATIC OP *
bfed75c6 178S_too_few_arguments(pTHX_ OP *o, const char *name)
79072805 179{
cea2e8a9 180 yyerror(Perl_form(aTHX_ "Not enough arguments for %s", name));
11343788 181 return o;
79072805
LW
182}
183
76e3520e 184STATIC OP *
bfed75c6 185S_too_many_arguments(pTHX_ OP *o, const char *name)
79072805 186{
cea2e8a9 187 yyerror(Perl_form(aTHX_ "Too many arguments for %s", name));
11343788 188 return o;
79072805
LW
189}
190
76e3520e 191STATIC void
6867be6d 192S_bad_type(pTHX_ I32 n, const char *t, const char *name, const OP *kid)
8990e307 193{
cea2e8a9 194 yyerror(Perl_form(aTHX_ "Type of arg %d to %s must be %s (not %s)",
53e06cf0 195 (int)n, name, t, OP_DESC(kid)));
8990e307
LW
196}
197
7a52d87a 198STATIC void
6867be6d 199S_no_bareword_allowed(pTHX_ const OP *o)
7a52d87a 200{
5a844595 201 qerror(Perl_mess(aTHX_
35c1215d
NC
202 "Bareword \"%"SVf"\" not allowed while \"strict subs\" in use",
203 cSVOPo_sv));
7a52d87a
GS
204}
205
79072805
LW
206/* "register" allocation */
207
208PADOFFSET
dd2155a4 209Perl_allocmy(pTHX_ char *name)
93a17b20 210{
97aff369 211 dVAR;
a0d0e21e 212 PADOFFSET off;
3edf23ff 213 const bool is_our = (PL_in_my == KEY_our);
a0d0e21e 214
59f00321 215 /* complain about "my $<special_var>" etc etc */
6b58708b 216 if (*name &&
3edf23ff 217 !(is_our ||
155aba94 218 isALPHA(name[1]) ||
39e02b42 219 (USE_UTF8_IN_NAMES && UTF8_IS_START(name[1])) ||
6b58708b 220 (name[1] == '_' && (*name == '$' || name[2]))))
834a4ddd 221 {
6b58708b 222 /* name[2] is true if strlen(name) > 2 */
c4d0567e 223 if (!isPRINT(name[1]) || strchr("\t\n\r\f", name[1])) {
2b92dfce
GS
224 /* 1999-02-27 mjd@plover.com */
225 char *p;
226 p = strchr(name, '\0');
227 /* The next block assumes the buffer is at least 205 chars
228 long. At present, it's always at least 256 chars. */
229 if (p-name > 200) {
230 strcpy(name+200, "...");
231 p = name+199;
232 }
233 else {
234 p[1] = '\0';
235 }
236 /* Move everything else down one character */
237 for (; p-name > 2; p--)
238 *p = *(p-1);
46fc3d4c 239 name[2] = toCTRL(name[1]);
240 name[1] = '^';
241 }
cea2e8a9 242 yyerror(Perl_form(aTHX_ "Can't use global %s in \"my\"",name));
a0d0e21e 243 }
748a9306 244
dd2155a4 245 /* check for duplicate declaration */
3edf23ff 246 pad_check_dup(name, is_our, (PL_curstash ? PL_curstash : PL_defstash));
33b8ce05 247
dd2155a4
DM
248 if (PL_in_my_stash && *name != '$') {
249 yyerror(Perl_form(aTHX_
250 "Can't declare class for non-scalar %s in \"%s\"",
3edf23ff 251 name, is_our ? "our" : "my"));
6b35e009
GS
252 }
253
dd2155a4 254 /* allocate a spare slot and store the name in that slot */
93a17b20 255
dd2155a4
DM
256 off = pad_add_name(name,
257 PL_in_my_stash,
3edf23ff 258 (is_our
133706a6
RGS
259 /* $_ is always in main::, even with our */
260 ? (PL_curstash && !strEQ(name,"$_") ? PL_curstash : PL_defstash)
5c284bb0 261 : NULL
dd2155a4
DM
262 ),
263 0 /* not fake */
264 );
265 return off;
79072805
LW
266}
267
79072805
LW
268/* Destructor */
269
270void
864dbfa3 271Perl_op_free(pTHX_ OP *o)
79072805 272{
27da23d5 273 dVAR;
acb36ea4 274 OPCODE type;
4026c95a 275 PADOFFSET refcnt;
79072805 276
2814eb74 277 if (!o || o->op_static)
79072805
LW
278 return;
279
7934575e
GS
280 if (o->op_private & OPpREFCOUNTED) {
281 switch (o->op_type) {
282 case OP_LEAVESUB:
283 case OP_LEAVESUBLV:
284 case OP_LEAVEEVAL:
285 case OP_LEAVE:
286 case OP_SCOPE:
287 case OP_LEAVEWRITE:
288 OP_REFCNT_LOCK;
4026c95a 289 refcnt = OpREFCNT_dec(o);
7934575e 290 OP_REFCNT_UNLOCK;
4026c95a
SH
291 if (refcnt)
292 return;
7934575e
GS
293 break;
294 default:
295 break;
296 }
297 }
298
11343788 299 if (o->op_flags & OPf_KIDS) {
6867be6d 300 register OP *kid, *nextkid;
11343788 301 for (kid = cUNOPo->op_first; kid; kid = nextkid) {
85e6fe83 302 nextkid = kid->op_sibling; /* Get before next freeing kid */
79072805 303 op_free(kid);
85e6fe83 304 }
79072805 305 }
acb36ea4
GS
306 type = o->op_type;
307 if (type == OP_NULL)
eb160463 308 type = (OPCODE)o->op_targ;
acb36ea4
GS
309
310 /* COP* is not cleared by op_clear() so that we may track line
311 * numbers etc even after null() */
312 if (type == OP_NEXTSTATE || type == OP_SETSTATE || type == OP_DBSTATE)
313 cop_free((COP*)o);
314
315 op_clear(o);
238a4c30 316 FreeOp(o);
4d494880
DM
317#ifdef DEBUG_LEAKING_SCALARS
318 if (PL_op == o)
5f66b61c 319 PL_op = NULL;
4d494880 320#endif
acb36ea4 321}
79072805 322
93c66552
DM
323void
324Perl_op_clear(pTHX_ OP *o)
acb36ea4 325{
13137afc 326
27da23d5 327 dVAR;
11343788 328 switch (o->op_type) {
acb36ea4
GS
329 case OP_NULL: /* Was holding old type, if any. */
330 case OP_ENTEREVAL: /* Was holding hints. */
acb36ea4 331 o->op_targ = 0;
a0d0e21e 332 break;
a6006777 333 default:
ac4c12e7 334 if (!(o->op_flags & OPf_REF)
0b94c7bb 335 || (PL_check[o->op_type] != MEMBER_TO_FPTR(Perl_ck_ftst)))
a6006777 336 break;
337 /* FALL THROUGH */
463ee0b2 338 case OP_GVSV:
79072805 339 case OP_GV:
a6006777 340 case OP_AELEMFAST:
6a077020
DM
341 if (! (o->op_type == OP_AELEMFAST && o->op_flags & OPf_SPECIAL)) {
342 /* not an OP_PADAV replacement */
350de78d 343#ifdef USE_ITHREADS
6a077020
DM
344 if (cPADOPo->op_padix > 0) {
345 /* No GvIN_PAD_off(cGVOPo_gv) here, because other references
346 * may still exist on the pad */
347 pad_swipe(cPADOPo->op_padix, TRUE);
348 cPADOPo->op_padix = 0;
349 }
350de78d 350#else
6a077020 351 SvREFCNT_dec(cSVOPo->op_sv);
a0714e2c 352 cSVOPo->op_sv = NULL;
350de78d 353#endif
6a077020 354 }
79072805 355 break;
a1ae71d2 356 case OP_METHOD_NAMED:
79072805 357 case OP_CONST:
11343788 358 SvREFCNT_dec(cSVOPo->op_sv);
a0714e2c 359 cSVOPo->op_sv = NULL;
3b1c21fa
AB
360#ifdef USE_ITHREADS
361 /** Bug #15654
362 Even if op_clear does a pad_free for the target of the op,
6a077020 363 pad_free doesn't actually remove the sv that exists in the pad;
3b1c21fa
AB
364 instead it lives on. This results in that it could be reused as
365 a target later on when the pad was reallocated.
366 **/
367 if(o->op_targ) {
368 pad_swipe(o->op_targ,1);
369 o->op_targ = 0;
370 }
371#endif
79072805 372 break;
748a9306
LW
373 case OP_GOTO:
374 case OP_NEXT:
375 case OP_LAST:
376 case OP_REDO:
11343788 377 if (o->op_flags & (OPf_SPECIAL|OPf_STACKED|OPf_KIDS))
748a9306
LW
378 break;
379 /* FALL THROUGH */
a0d0e21e 380 case OP_TRANS:
acb36ea4 381 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
a0ed51b3 382 SvREFCNT_dec(cSVOPo->op_sv);
a0714e2c 383 cSVOPo->op_sv = NULL;
acb36ea4
GS
384 }
385 else {
a0ed51b3 386 Safefree(cPVOPo->op_pv);
bd61b366 387 cPVOPo->op_pv = NULL;
acb36ea4 388 }
a0d0e21e
LW
389 break;
390 case OP_SUBST:
11343788 391 op_free(cPMOPo->op_pmreplroot);
971a9dd3 392 goto clear_pmop;
748a9306 393 case OP_PUSHRE:
971a9dd3 394#ifdef USE_ITHREADS
ba89bb6e 395 if (INT2PTR(PADOFFSET, cPMOPo->op_pmreplroot)) {
dd2155a4
DM
396 /* No GvIN_PAD_off here, because other references may still
397 * exist on the pad */
398 pad_swipe(INT2PTR(PADOFFSET, cPMOPo->op_pmreplroot), TRUE);
971a9dd3
GS
399 }
400#else
401 SvREFCNT_dec((SV*)cPMOPo->op_pmreplroot);
402#endif
403 /* FALL THROUGH */
a0d0e21e 404 case OP_MATCH:
8782bef2 405 case OP_QR:
971a9dd3 406clear_pmop:
cb55de95 407 {
551405c4 408 HV * const pmstash = PmopSTASH(cPMOPo);
0565a181 409 if (pmstash && !SvIS_FREED(pmstash)) {
551405c4 410 MAGIC * const mg = mg_find((SV*)pmstash, PERL_MAGIC_symtab);
8d2f4536
NC
411 if (mg) {
412 PMOP *pmop = (PMOP*) mg->mg_obj;
413 PMOP *lastpmop = NULL;
414 while (pmop) {
415 if (cPMOPo == pmop) {
416 if (lastpmop)
417 lastpmop->op_pmnext = pmop->op_pmnext;
418 else
419 mg->mg_obj = (SV*) pmop->op_pmnext;
420 break;
421 }
422 lastpmop = pmop;
423 pmop = pmop->op_pmnext;
cb55de95 424 }
cb55de95 425 }
83da49e6 426 }
05ec9bb3 427 PmopSTASH_free(cPMOPo);
cb55de95 428 }
5f66b61c 429 cPMOPo->op_pmreplroot = NULL;
5f8cb046
DM
430 /* we use the "SAFE" version of the PM_ macros here
431 * since sv_clean_all might release some PMOPs
432 * after PL_regex_padav has been cleared
433 * and the clearing of PL_regex_padav needs to
434 * happen before sv_clean_all
435 */
436 ReREFCNT_dec(PM_GETRE_SAFE(cPMOPo));
5f66b61c 437 PM_SETRE_SAFE(cPMOPo, NULL);
13137afc
AB
438#ifdef USE_ITHREADS
439 if(PL_regex_pad) { /* We could be in destruction */
440 av_push((AV*) PL_regex_pad[0],(SV*) PL_regex_pad[(cPMOPo)->op_pmoffset]);
1cc8b4c5 441 SvREPADTMP_on(PL_regex_pad[(cPMOPo)->op_pmoffset]);
13137afc
AB
442 PM_SETRE(cPMOPo, (cPMOPo)->op_pmoffset);
443 }
1eb1540c 444#endif
13137afc 445
a0d0e21e 446 break;
79072805
LW
447 }
448
743e66e6 449 if (o->op_targ > 0) {
11343788 450 pad_free(o->op_targ);
743e66e6
GS
451 o->op_targ = 0;
452 }
79072805
LW
453}
454
76e3520e 455STATIC void
3eb57f73
HS
456S_cop_free(pTHX_ COP* cop)
457{
05ec9bb3
NIS
458 Safefree(cop->cop_label); /* FIXME: treaddead ??? */
459 CopFILE_free(cop);
460 CopSTASH_free(cop);
0453d815 461 if (! specialWARN(cop->cop_warnings))
3eb57f73 462 SvREFCNT_dec(cop->cop_warnings);
05ec9bb3
NIS
463 if (! specialCopIO(cop->cop_io)) {
464#ifdef USE_ITHREADS
bb263b4e 465 /*EMPTY*/
05ec9bb3 466#else
ac27b0f5 467 SvREFCNT_dec(cop->cop_io);
05ec9bb3
NIS
468#endif
469 }
3eb57f73
HS
470}
471
93c66552
DM
472void
473Perl_op_null(pTHX_ OP *o)
8990e307 474{
27da23d5 475 dVAR;
acb36ea4
GS
476 if (o->op_type == OP_NULL)
477 return;
478 op_clear(o);
11343788
MB
479 o->op_targ = o->op_type;
480 o->op_type = OP_NULL;
22c35a8c 481 o->op_ppaddr = PL_ppaddr[OP_NULL];
8990e307
LW
482}
483
4026c95a
SH
484void
485Perl_op_refcnt_lock(pTHX)
486{
27da23d5 487 dVAR;
96a5add6 488 PERL_UNUSED_CONTEXT;
4026c95a
SH
489 OP_REFCNT_LOCK;
490}
491
492void
493Perl_op_refcnt_unlock(pTHX)
494{
27da23d5 495 dVAR;
96a5add6 496 PERL_UNUSED_CONTEXT;
4026c95a
SH
497 OP_REFCNT_UNLOCK;
498}
499
79072805
LW
500/* Contextualizers */
501
463ee0b2 502#define LINKLIST(o) ((o)->op_next ? (o)->op_next : linklist((OP*)o))
79072805
LW
503
504OP *
864dbfa3 505Perl_linklist(pTHX_ OP *o)
79072805 506{
3edf23ff 507 OP *first;
79072805 508
11343788
MB
509 if (o->op_next)
510 return o->op_next;
79072805
LW
511
512 /* establish postfix order */
3edf23ff
AL
513 first = cUNOPo->op_first;
514 if (first) {
6867be6d 515 register OP *kid;
3edf23ff
AL
516 o->op_next = LINKLIST(first);
517 kid = first;
518 for (;;) {
519 if (kid->op_sibling) {
79072805 520 kid->op_next = LINKLIST(kid->op_sibling);
3edf23ff
AL
521 kid = kid->op_sibling;
522 } else {
11343788 523 kid->op_next = o;
3edf23ff
AL
524 break;
525 }
79072805
LW
526 }
527 }
528 else
11343788 529 o->op_next = o;
79072805 530
11343788 531 return o->op_next;
79072805
LW
532}
533
534OP *
864dbfa3 535Perl_scalarkids(pTHX_ OP *o)
79072805 536{
11343788 537 if (o && o->op_flags & OPf_KIDS) {
bfed75c6 538 OP *kid;
11343788 539 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
79072805
LW
540 scalar(kid);
541 }
11343788 542 return o;
79072805
LW
543}
544
76e3520e 545STATIC OP *
cea2e8a9 546S_scalarboolean(pTHX_ OP *o)
8990e307 547{
97aff369 548 dVAR;
d008e5eb 549 if (o->op_type == OP_SASSIGN && cBINOPo->op_first->op_type == OP_CONST) {
d008e5eb 550 if (ckWARN(WARN_SYNTAX)) {
6867be6d 551 const line_t oldline = CopLINE(PL_curcop);
a0d0e21e 552
d008e5eb 553 if (PL_copline != NOLINE)
57843af0 554 CopLINE_set(PL_curcop, PL_copline);
9014280d 555 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Found = in conditional, should be ==");
57843af0 556 CopLINE_set(PL_curcop, oldline);
d008e5eb 557 }
a0d0e21e 558 }
11343788 559 return scalar(o);
8990e307
LW
560}
561
562OP *
864dbfa3 563Perl_scalar(pTHX_ OP *o)
79072805 564{
27da23d5 565 dVAR;
79072805
LW
566 OP *kid;
567
a0d0e21e 568 /* assumes no premature commitment */
551405c4 569 if (!o || PL_error_count || (o->op_flags & OPf_WANT)
5dc0d613 570 || o->op_type == OP_RETURN)
7e363e51 571 {
11343788 572 return o;
7e363e51 573 }
79072805 574
5dc0d613 575 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_SCALAR;
79072805 576
11343788 577 switch (o->op_type) {
79072805 578 case OP_REPEAT:
11343788 579 scalar(cBINOPo->op_first);
8990e307 580 break;
79072805
LW
581 case OP_OR:
582 case OP_AND:
583 case OP_COND_EXPR:
11343788 584 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
8990e307 585 scalar(kid);
79072805 586 break;
a0d0e21e 587 case OP_SPLIT:
11343788 588 if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) {
a0d0e21e 589 if (!kPMOP->op_pmreplroot)
12bcd1a6 590 deprecate_old("implicit split to @_");
a0d0e21e
LW
591 }
592 /* FALL THROUGH */
79072805 593 case OP_MATCH:
8782bef2 594 case OP_QR:
79072805
LW
595 case OP_SUBST:
596 case OP_NULL:
8990e307 597 default:
11343788
MB
598 if (o->op_flags & OPf_KIDS) {
599 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
8990e307
LW
600 scalar(kid);
601 }
79072805
LW
602 break;
603 case OP_LEAVE:
604 case OP_LEAVETRY:
5dc0d613 605 kid = cLISTOPo->op_first;
54310121 606 scalar(kid);
155aba94 607 while ((kid = kid->op_sibling)) {
54310121 608 if (kid->op_sibling)
609 scalarvoid(kid);
610 else
611 scalar(kid);
612 }
3280af22 613 WITH_THR(PL_curcop = &PL_compiling);
54310121 614 break;
748a9306 615 case OP_SCOPE:
79072805 616 case OP_LINESEQ:
8990e307 617 case OP_LIST:
11343788 618 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
79072805
LW
619 if (kid->op_sibling)
620 scalarvoid(kid);
621 else
622 scalar(kid);
623 }
3280af22 624 WITH_THR(PL_curcop = &PL_compiling);
79072805 625 break;
a801c63c
RGS
626 case OP_SORT:
627 if (ckWARN(WARN_VOID))
9014280d 628 Perl_warner(aTHX_ packWARN(WARN_VOID), "Useless use of sort in scalar context");
79072805 629 }
11343788 630 return o;
79072805
LW
631}
632
633OP *
864dbfa3 634Perl_scalarvoid(pTHX_ OP *o)
79072805 635{
27da23d5 636 dVAR;
79072805 637 OP *kid;
c445ea15 638 const char* useless = NULL;
8990e307 639 SV* sv;
2ebea0a1
GS
640 U8 want;
641
acb36ea4
GS
642 if (o->op_type == OP_NEXTSTATE
643 || o->op_type == OP_SETSTATE
644 || o->op_type == OP_DBSTATE
645 || (o->op_type == OP_NULL && (o->op_targ == OP_NEXTSTATE
646 || o->op_targ == OP_SETSTATE
647 || o->op_targ == OP_DBSTATE)))
2ebea0a1 648 PL_curcop = (COP*)o; /* for warning below */
79072805 649
54310121 650 /* assumes no premature commitment */
2ebea0a1
GS
651 want = o->op_flags & OPf_WANT;
652 if ((want && want != OPf_WANT_SCALAR) || PL_error_count
5dc0d613 653 || o->op_type == OP_RETURN)
7e363e51 654 {
11343788 655 return o;
7e363e51 656 }
79072805 657
b162f9ea 658 if ((o->op_private & OPpTARGET_MY)
7e363e51
GS
659 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
660 {
b162f9ea 661 return scalar(o); /* As if inside SASSIGN */
7e363e51 662 }
1c846c1f 663
5dc0d613 664 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
79072805 665
11343788 666 switch (o->op_type) {
79072805 667 default:
22c35a8c 668 if (!(PL_opargs[o->op_type] & OA_FOLDCONST))
8990e307 669 break;
36477c24 670 /* FALL THROUGH */
671 case OP_REPEAT:
11343788 672 if (o->op_flags & OPf_STACKED)
8990e307 673 break;
5d82c453
GA
674 goto func_ops;
675 case OP_SUBSTR:
676 if (o->op_private == 4)
677 break;
8990e307
LW
678 /* FALL THROUGH */
679 case OP_GVSV:
680 case OP_WANTARRAY:
681 case OP_GV:
682 case OP_PADSV:
683 case OP_PADAV:
684 case OP_PADHV:
685 case OP_PADANY:
686 case OP_AV2ARYLEN:
8990e307 687 case OP_REF:
a0d0e21e
LW
688 case OP_REFGEN:
689 case OP_SREFGEN:
8990e307
LW
690 case OP_DEFINED:
691 case OP_HEX:
692 case OP_OCT:
693 case OP_LENGTH:
8990e307
LW
694 case OP_VEC:
695 case OP_INDEX:
696 case OP_RINDEX:
697 case OP_SPRINTF:
698 case OP_AELEM:
699 case OP_AELEMFAST:
700 case OP_ASLICE:
8990e307
LW
701 case OP_HELEM:
702 case OP_HSLICE:
703 case OP_UNPACK:
704 case OP_PACK:
8990e307
LW
705 case OP_JOIN:
706 case OP_LSLICE:
707 case OP_ANONLIST:
708 case OP_ANONHASH:
709 case OP_SORT:
710 case OP_REVERSE:
711 case OP_RANGE:
712 case OP_FLIP:
713 case OP_FLOP:
714 case OP_CALLER:
715 case OP_FILENO:
716 case OP_EOF:
717 case OP_TELL:
718 case OP_GETSOCKNAME:
719 case OP_GETPEERNAME:
720 case OP_READLINK:
721 case OP_TELLDIR:
722 case OP_GETPPID:
723 case OP_GETPGRP:
724 case OP_GETPRIORITY:
725 case OP_TIME:
726 case OP_TMS:
727 case OP_LOCALTIME:
728 case OP_GMTIME:
729 case OP_GHBYNAME:
730 case OP_GHBYADDR:
731 case OP_GHOSTENT:
732 case OP_GNBYNAME:
733 case OP_GNBYADDR:
734 case OP_GNETENT:
735 case OP_GPBYNAME:
736 case OP_GPBYNUMBER:
737 case OP_GPROTOENT:
738 case OP_GSBYNAME:
739 case OP_GSBYPORT:
740 case OP_GSERVENT:
741 case OP_GPWNAM:
742 case OP_GPWUID:
743 case OP_GGRNAM:
744 case OP_GGRGID:
745 case OP_GETLOGIN:
78e1b766 746 case OP_PROTOTYPE:
5d82c453 747 func_ops:
64aac5a9 748 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))
53e06cf0 749 useless = OP_DESC(o);
8990e307
LW
750 break;
751
9f82cd5f
YST
752 case OP_NOT:
753 kid = cUNOPo->op_first;
754 if (kid->op_type != OP_MATCH && kid->op_type != OP_SUBST &&
755 kid->op_type != OP_TRANS) {
756 goto func_ops;
757 }
758 useless = "negative pattern binding (!~)";
759 break;
760
8990e307
LW
761 case OP_RV2GV:
762 case OP_RV2SV:
763 case OP_RV2AV:
764 case OP_RV2HV:
192587c2 765 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)) &&
11343788 766 (!o->op_sibling || o->op_sibling->op_type != OP_READLINE))
8990e307
LW
767 useless = "a variable";
768 break;
79072805
LW
769
770 case OP_CONST:
7766f137 771 sv = cSVOPo_sv;
7a52d87a
GS
772 if (cSVOPo->op_private & OPpCONST_STRICT)
773 no_bareword_allowed(o);
774 else {
d008e5eb
GS
775 if (ckWARN(WARN_VOID)) {
776 useless = "a constant";
e7fec78e 777 /* don't warn on optimised away booleans, eg
b5a930ec 778 * use constant Foo, 5; Foo || print; */
e7fec78e
DM
779 if (cSVOPo->op_private & OPpCONST_SHORTCIRCUIT)
780 useless = 0;
960b4253
MG
781 /* the constants 0 and 1 are permitted as they are
782 conventionally used as dummies in constructs like
783 1 while some_condition_with_side_effects; */
e7fec78e 784 else if (SvNIOK(sv) && (SvNV(sv) == 0.0 || SvNV(sv) == 1.0))
d008e5eb
GS
785 useless = 0;
786 else if (SvPOK(sv)) {
a52fe3ac
A
787 /* perl4's way of mixing documentation and code
788 (before the invention of POD) was based on a
789 trick to mix nroff and perl code. The trick was
790 built upon these three nroff macros being used in
791 void context. The pink camel has the details in
792 the script wrapman near page 319. */
6136c704
AL
793 const char * const maybe_macro = SvPVX_const(sv);
794 if (strnEQ(maybe_macro, "di", 2) ||
795 strnEQ(maybe_macro, "ds", 2) ||
796 strnEQ(maybe_macro, "ig", 2))
d008e5eb
GS
797 useless = 0;
798 }
8990e307
LW
799 }
800 }
93c66552 801 op_null(o); /* don't execute or even remember it */
79072805
LW
802 break;
803
804 case OP_POSTINC:
11343788 805 o->op_type = OP_PREINC; /* pre-increment is faster */
22c35a8c 806 o->op_ppaddr = PL_ppaddr[OP_PREINC];
79072805
LW
807 break;
808
809 case OP_POSTDEC:
11343788 810 o->op_type = OP_PREDEC; /* pre-decrement is faster */
22c35a8c 811 o->op_ppaddr = PL_ppaddr[OP_PREDEC];
79072805
LW
812 break;
813
679d6c4e
HS
814 case OP_I_POSTINC:
815 o->op_type = OP_I_PREINC; /* pre-increment is faster */
816 o->op_ppaddr = PL_ppaddr[OP_I_PREINC];
817 break;
818
819 case OP_I_POSTDEC:
820 o->op_type = OP_I_PREDEC; /* pre-decrement is faster */
821 o->op_ppaddr = PL_ppaddr[OP_I_PREDEC];
822 break;
823
79072805
LW
824 case OP_OR:
825 case OP_AND:
c963b151 826 case OP_DOR:
79072805 827 case OP_COND_EXPR:
0d863452
RH
828 case OP_ENTERGIVEN:
829 case OP_ENTERWHEN:
11343788 830 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
79072805
LW
831 scalarvoid(kid);
832 break;
5aabfad6 833
a0d0e21e 834 case OP_NULL:
11343788 835 if (o->op_flags & OPf_STACKED)
a0d0e21e 836 break;
5aabfad6 837 /* FALL THROUGH */
2ebea0a1
GS
838 case OP_NEXTSTATE:
839 case OP_DBSTATE:
79072805
LW
840 case OP_ENTERTRY:
841 case OP_ENTER:
11343788 842 if (!(o->op_flags & OPf_KIDS))
79072805 843 break;
54310121 844 /* FALL THROUGH */
463ee0b2 845 case OP_SCOPE:
79072805
LW
846 case OP_LEAVE:
847 case OP_LEAVETRY:
a0d0e21e 848 case OP_LEAVELOOP:
79072805 849 case OP_LINESEQ:
79072805 850 case OP_LIST:
0d863452
RH
851 case OP_LEAVEGIVEN:
852 case OP_LEAVEWHEN:
11343788 853 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
79072805
LW
854 scalarvoid(kid);
855 break;
c90c0ff4 856 case OP_ENTEREVAL:
5196be3e 857 scalarkids(o);
c90c0ff4 858 break;
5aabfad6 859 case OP_REQUIRE:
c90c0ff4 860 /* all requires must return a boolean value */
5196be3e 861 o->op_flags &= ~OPf_WANT;
d6483035
GS
862 /* FALL THROUGH */
863 case OP_SCALAR:
5196be3e 864 return scalar(o);
a0d0e21e 865 case OP_SPLIT:
11343788 866 if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) {
a0d0e21e 867 if (!kPMOP->op_pmreplroot)
12bcd1a6 868 deprecate_old("implicit split to @_");
a0d0e21e
LW
869 }
870 break;
79072805 871 }
411caa50 872 if (useless && ckWARN(WARN_VOID))
9014280d 873 Perl_warner(aTHX_ packWARN(WARN_VOID), "Useless use of %s in void context", useless);
11343788 874 return o;
79072805
LW
875}
876
877OP *
864dbfa3 878Perl_listkids(pTHX_ OP *o)
79072805 879{
11343788 880 if (o && o->op_flags & OPf_KIDS) {
6867be6d 881 OP *kid;
11343788 882 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
79072805
LW
883 list(kid);
884 }
11343788 885 return o;
79072805
LW
886}
887
888OP *
864dbfa3 889Perl_list(pTHX_ OP *o)
79072805 890{
27da23d5 891 dVAR;
79072805
LW
892 OP *kid;
893
a0d0e21e 894 /* assumes no premature commitment */
3280af22 895 if (!o || (o->op_flags & OPf_WANT) || PL_error_count
5dc0d613 896 || o->op_type == OP_RETURN)
7e363e51 897 {
11343788 898 return o;
7e363e51 899 }
79072805 900
b162f9ea 901 if ((o->op_private & OPpTARGET_MY)
7e363e51
GS
902 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
903 {
b162f9ea 904 return o; /* As if inside SASSIGN */
7e363e51 905 }
1c846c1f 906
5dc0d613 907 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_LIST;
79072805 908
11343788 909 switch (o->op_type) {
79072805
LW
910 case OP_FLOP:
911 case OP_REPEAT:
11343788 912 list(cBINOPo->op_first);
79072805
LW
913 break;
914 case OP_OR:
915 case OP_AND:
916 case OP_COND_EXPR:
11343788 917 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
79072805
LW
918 list(kid);
919 break;
920 default:
921 case OP_MATCH:
8782bef2 922 case OP_QR:
79072805
LW
923 case OP_SUBST:
924 case OP_NULL:
11343788 925 if (!(o->op_flags & OPf_KIDS))
79072805 926 break;
11343788
MB
927 if (!o->op_next && cUNOPo->op_first->op_type == OP_FLOP) {
928 list(cBINOPo->op_first);
929 return gen_constant_list(o);
79072805
LW
930 }
931 case OP_LIST:
11343788 932 listkids(o);
79072805
LW
933 break;
934 case OP_LEAVE:
935 case OP_LEAVETRY:
5dc0d613 936 kid = cLISTOPo->op_first;
54310121 937 list(kid);
155aba94 938 while ((kid = kid->op_sibling)) {
54310121 939 if (kid->op_sibling)
940 scalarvoid(kid);
941 else
942 list(kid);
943 }
3280af22 944 WITH_THR(PL_curcop = &PL_compiling);
54310121 945 break;
748a9306 946 case OP_SCOPE:
79072805 947 case OP_LINESEQ:
11343788 948 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
79072805
LW
949 if (kid->op_sibling)
950 scalarvoid(kid);
951 else
952 list(kid);
953 }
3280af22 954 WITH_THR(PL_curcop = &PL_compiling);
79072805 955 break;
c90c0ff4 956 case OP_REQUIRE:
957 /* all requires must return a boolean value */
5196be3e
MB
958 o->op_flags &= ~OPf_WANT;
959 return scalar(o);
79072805 960 }
11343788 961 return o;
79072805
LW
962}
963
964OP *
864dbfa3 965Perl_scalarseq(pTHX_ OP *o)
79072805 966{
97aff369 967 dVAR;
11343788
MB
968 if (o) {
969 if (o->op_type == OP_LINESEQ ||
970 o->op_type == OP_SCOPE ||
971 o->op_type == OP_LEAVE ||
972 o->op_type == OP_LEAVETRY)
463ee0b2 973 {
6867be6d 974 OP *kid;
11343788 975 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
ed6116ce 976 if (kid->op_sibling) {
463ee0b2 977 scalarvoid(kid);
ed6116ce 978 }
463ee0b2 979 }
3280af22 980 PL_curcop = &PL_compiling;
79072805 981 }
11343788 982 o->op_flags &= ~OPf_PARENS;
3280af22 983 if (PL_hints & HINT_BLOCK_SCOPE)
11343788 984 o->op_flags |= OPf_PARENS;
79072805 985 }
8990e307 986 else
11343788
MB
987 o = newOP(OP_STUB, 0);
988 return o;
79072805
LW
989}
990
76e3520e 991STATIC OP *
cea2e8a9 992S_modkids(pTHX_ OP *o, I32 type)
79072805 993{
11343788 994 if (o && o->op_flags & OPf_KIDS) {
6867be6d 995 OP *kid;
11343788 996 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
463ee0b2 997 mod(kid, type);
79072805 998 }
11343788 999 return o;
79072805
LW
1000}
1001
ff7298cb 1002/* Propagate lvalue ("modifiable") context to an op and its children.
ddeae0f1
DM
1003 * 'type' represents the context type, roughly based on the type of op that
1004 * would do the modifying, although local() is represented by OP_NULL.
1005 * It's responsible for detecting things that can't be modified, flag
1006 * things that need to behave specially in an lvalue context (e.g., "$$x = 5"
1007 * might have to vivify a reference in $x), and so on.
1008 *
1009 * For example, "$a+1 = 2" would cause mod() to be called with o being
1010 * OP_ADD and type being OP_SASSIGN, and would output an error.
1011 */
1012
79072805 1013OP *
864dbfa3 1014Perl_mod(pTHX_ OP *o, I32 type)
79072805 1015{
27da23d5 1016 dVAR;
79072805 1017 OP *kid;
ddeae0f1
DM
1018 /* -1 = error on localize, 0 = ignore localize, 1 = ok to localize */
1019 int localize = -1;
79072805 1020
3280af22 1021 if (!o || PL_error_count)
11343788 1022 return o;
79072805 1023
b162f9ea 1024 if ((o->op_private & OPpTARGET_MY)
7e363e51
GS
1025 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1026 {
b162f9ea 1027 return o;
7e363e51 1028 }
1c846c1f 1029
11343788 1030 switch (o->op_type) {
68dc0745 1031 case OP_UNDEF:
ddeae0f1 1032 localize = 0;
3280af22 1033 PL_modcount++;
5dc0d613 1034 return o;
a0d0e21e 1035 case OP_CONST:
11343788 1036 if (!(o->op_private & (OPpCONST_ARYBASE)))
a0d0e21e 1037 goto nomod;
54dc0f91 1038 localize = 0;
3280af22 1039 if (PL_eval_start && PL_eval_start->op_type == OP_CONST) {
7766f137 1040 PL_compiling.cop_arybase = (I32)SvIV(cSVOPx(PL_eval_start)->op_sv);
3280af22 1041 PL_eval_start = 0;
a0d0e21e
LW
1042 }
1043 else if (!type) {
3280af22
NIS
1044 SAVEI32(PL_compiling.cop_arybase);
1045 PL_compiling.cop_arybase = 0;
a0d0e21e
LW
1046 }
1047 else if (type == OP_REFGEN)
1048 goto nomod;
1049 else
cea2e8a9 1050 Perl_croak(aTHX_ "That use of $[ is unsupported");
a0d0e21e 1051 break;
5f05dabc 1052 case OP_STUB:
5196be3e 1053 if (o->op_flags & OPf_PARENS)
5f05dabc 1054 break;
1055 goto nomod;
a0d0e21e
LW
1056 case OP_ENTERSUB:
1057 if ((type == OP_UNDEF || type == OP_REFGEN) &&
11343788
MB
1058 !(o->op_flags & OPf_STACKED)) {
1059 o->op_type = OP_RV2CV; /* entersub => rv2cv */
e26df76a
NC
1060 /* The default is to set op_private to the number of children,
1061 which for a UNOP such as RV2CV is always 1. And w're using
1062 the bit for a flag in RV2CV, so we need it clear. */
1063 o->op_private &= ~1;
22c35a8c 1064 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
11343788 1065 assert(cUNOPo->op_first->op_type == OP_NULL);
93c66552 1066 op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
79072805
LW
1067 break;
1068 }
95f0a2f1
SB
1069 else if (o->op_private & OPpENTERSUB_NOMOD)
1070 return o;
cd06dffe
GS
1071 else { /* lvalue subroutine call */
1072 o->op_private |= OPpLVAL_INTRO;
e6438c1a 1073 PL_modcount = RETURN_UNLIMITED_NUMBER;
4978d6d9 1074 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN) {
cd06dffe
GS
1075 /* Backward compatibility mode: */
1076 o->op_private |= OPpENTERSUB_INARGS;
1077 break;
1078 }
1079 else { /* Compile-time error message: */
1080 OP *kid = cUNOPo->op_first;
1081 CV *cv;
1082 OP *okid;
1083
1084 if (kid->op_type == OP_PUSHMARK)
1085 goto skip_kids;
1086 if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
1087 Perl_croak(aTHX_
1088 "panic: unexpected lvalue entersub "
55140b79 1089 "args: type/targ %ld:%"UVuf,
3d811634 1090 (long)kid->op_type, (UV)kid->op_targ);
cd06dffe
GS
1091 kid = kLISTOP->op_first;
1092 skip_kids:
1093 while (kid->op_sibling)
1094 kid = kid->op_sibling;
1095 if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) {
1096 /* Indirect call */
1097 if (kid->op_type == OP_METHOD_NAMED
1098 || kid->op_type == OP_METHOD)
1099 {
87d7fd28 1100 UNOP *newop;
b2ffa427 1101
87d7fd28 1102 NewOp(1101, newop, 1, UNOP);
349fd7b7
GS
1103 newop->op_type = OP_RV2CV;
1104 newop->op_ppaddr = PL_ppaddr[OP_RV2CV];
5f66b61c 1105 newop->op_first = NULL;
87d7fd28
GS
1106 newop->op_next = (OP*)newop;
1107 kid->op_sibling = (OP*)newop;
349fd7b7 1108 newop->op_private |= OPpLVAL_INTRO;
e26df76a 1109 newop->op_private &= ~1;
cd06dffe
GS
1110 break;
1111 }
b2ffa427 1112
cd06dffe
GS
1113 if (kid->op_type != OP_RV2CV)
1114 Perl_croak(aTHX_
1115 "panic: unexpected lvalue entersub "
55140b79 1116 "entry via type/targ %ld:%"UVuf,
3d811634 1117 (long)kid->op_type, (UV)kid->op_targ);
cd06dffe
GS
1118 kid->op_private |= OPpLVAL_INTRO;
1119 break; /* Postpone until runtime */
1120 }
b2ffa427
NIS
1121
1122 okid = kid;
cd06dffe
GS
1123 kid = kUNOP->op_first;
1124 if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV)
1125 kid = kUNOP->op_first;
b2ffa427 1126 if (kid->op_type == OP_NULL)
cd06dffe
GS
1127 Perl_croak(aTHX_
1128 "Unexpected constant lvalue entersub "
55140b79 1129 "entry via type/targ %ld:%"UVuf,
3d811634 1130 (long)kid->op_type, (UV)kid->op_targ);
cd06dffe
GS
1131 if (kid->op_type != OP_GV) {
1132 /* Restore RV2CV to check lvalueness */
1133 restore_2cv:
1134 if (kid->op_next && kid->op_next != kid) { /* Happens? */
1135 okid->op_next = kid->op_next;
1136 kid->op_next = okid;
1137 }
1138 else
5f66b61c 1139 okid->op_next = NULL;
cd06dffe
GS
1140 okid->op_type = OP_RV2CV;
1141 okid->op_targ = 0;
1142 okid->op_ppaddr = PL_ppaddr[OP_RV2CV];
1143 okid->op_private |= OPpLVAL_INTRO;
e26df76a 1144 okid->op_private &= ~1;
cd06dffe
GS
1145 break;
1146 }
b2ffa427 1147
638eceb6 1148 cv = GvCV(kGVOP_gv);
1c846c1f 1149 if (!cv)
cd06dffe
GS
1150 goto restore_2cv;
1151 if (CvLVALUE(cv))
1152 break;
1153 }
1154 }
79072805
LW
1155 /* FALL THROUGH */
1156 default:
a0d0e21e 1157 nomod:
6fbb66d6
NC
1158 /* grep, foreach, subcalls, refgen */
1159 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN)
a0d0e21e 1160 break;
cea2e8a9 1161 yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
638bc118 1162 (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
cd06dffe
GS
1163 ? "do block"
1164 : (o->op_type == OP_ENTERSUB
1165 ? "non-lvalue subroutine call"
53e06cf0 1166 : OP_DESC(o))),
22c35a8c 1167 type ? PL_op_desc[type] : "local"));
11343788 1168 return o;
79072805 1169
a0d0e21e
LW
1170 case OP_PREINC:
1171 case OP_PREDEC:
1172 case OP_POW:
1173 case OP_MULTIPLY:
1174 case OP_DIVIDE:
1175 case OP_MODULO:
1176 case OP_REPEAT:
1177 case OP_ADD:
1178 case OP_SUBTRACT:
1179 case OP_CONCAT:
1180 case OP_LEFT_SHIFT:
1181 case OP_RIGHT_SHIFT:
1182 case OP_BIT_AND:
1183 case OP_BIT_XOR:
1184 case OP_BIT_OR:
1185 case OP_I_MULTIPLY:
1186 case OP_I_DIVIDE:
1187 case OP_I_MODULO:
1188 case OP_I_ADD:
1189 case OP_I_SUBTRACT:
11343788 1190 if (!(o->op_flags & OPf_STACKED))
a0d0e21e 1191 goto nomod;
3280af22 1192 PL_modcount++;
a0d0e21e 1193 break;
b2ffa427 1194
79072805 1195 case OP_COND_EXPR:
ddeae0f1 1196 localize = 1;
11343788 1197 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
463ee0b2 1198 mod(kid, type);
79072805
LW
1199 break;
1200
1201 case OP_RV2AV:
1202 case OP_RV2HV:
11343788 1203 if (type == OP_REFGEN && o->op_flags & OPf_PARENS) {
e6438c1a 1204 PL_modcount = RETURN_UNLIMITED_NUMBER;
11343788 1205 return o; /* Treat \(@foo) like ordinary list. */
748a9306
LW
1206 }
1207 /* FALL THROUGH */
79072805 1208 case OP_RV2GV:
5dc0d613 1209 if (scalar_mod_type(o, type))
3fe9a6f1 1210 goto nomod;
11343788 1211 ref(cUNOPo->op_first, o->op_type);
79072805 1212 /* FALL THROUGH */
79072805
LW
1213 case OP_ASLICE:
1214 case OP_HSLICE:
78f9721b
SM
1215 if (type == OP_LEAVESUBLV)
1216 o->op_private |= OPpMAYBE_LVSUB;
ddeae0f1 1217 localize = 1;
78f9721b
SM
1218 /* FALL THROUGH */
1219 case OP_AASSIGN:
93a17b20
LW
1220 case OP_NEXTSTATE:
1221 case OP_DBSTATE:
e6438c1a 1222 PL_modcount = RETURN_UNLIMITED_NUMBER;
79072805 1223 break;
463ee0b2 1224 case OP_RV2SV:
aeea060c 1225 ref(cUNOPo->op_first, o->op_type);
ddeae0f1 1226 localize = 1;
463ee0b2 1227 /* FALL THROUGH */
79072805 1228 case OP_GV:
463ee0b2 1229 case OP_AV2ARYLEN:
3280af22 1230 PL_hints |= HINT_BLOCK_SCOPE;
463ee0b2 1231 case OP_SASSIGN:
bf4b1e52
GS
1232 case OP_ANDASSIGN:
1233 case OP_ORASSIGN:
c963b151 1234 case OP_DORASSIGN:
ddeae0f1
DM
1235 PL_modcount++;
1236 break;
1237
8990e307 1238 case OP_AELEMFAST:
6a077020 1239 localize = -1;
3280af22 1240 PL_modcount++;
8990e307
LW
1241 break;
1242
748a9306
LW
1243 case OP_PADAV:
1244 case OP_PADHV:
e6438c1a 1245 PL_modcount = RETURN_UNLIMITED_NUMBER;
5196be3e
MB
1246 if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
1247 return o; /* Treat \(@foo) like ordinary list. */
1248 if (scalar_mod_type(o, type))
3fe9a6f1 1249 goto nomod;
78f9721b
SM
1250 if (type == OP_LEAVESUBLV)
1251 o->op_private |= OPpMAYBE_LVSUB;
748a9306
LW
1252 /* FALL THROUGH */
1253 case OP_PADSV:
3280af22 1254 PL_modcount++;
ddeae0f1 1255 if (!type) /* local() */
cea2e8a9 1256 Perl_croak(aTHX_ "Can't localize lexical variable %s",
dd2155a4 1257 PAD_COMPNAME_PV(o->op_targ));
463ee0b2
LW
1258 break;
1259
748a9306 1260 case OP_PUSHMARK:
ddeae0f1 1261 localize = 0;
748a9306 1262 break;
b2ffa427 1263
69969c6f
SB
1264 case OP_KEYS:
1265 if (type != OP_SASSIGN)
1266 goto nomod;
5d82c453
GA
1267 goto lvalue_func;
1268 case OP_SUBSTR:
1269 if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */
1270 goto nomod;
5f05dabc 1271 /* FALL THROUGH */
a0d0e21e 1272 case OP_POS:
463ee0b2 1273 case OP_VEC:
78f9721b
SM
1274 if (type == OP_LEAVESUBLV)
1275 o->op_private |= OPpMAYBE_LVSUB;
5d82c453 1276 lvalue_func:
11343788
MB
1277 pad_free(o->op_targ);
1278 o->op_targ = pad_alloc(o->op_type, SVs_PADMY);
5dc0d613 1279 assert(SvTYPE(PAD_SV(o->op_targ)) == SVt_NULL);
11343788
MB
1280 if (o->op_flags & OPf_KIDS)
1281 mod(cBINOPo->op_first->op_sibling, type);
463ee0b2 1282 break;
a0d0e21e 1283
463ee0b2
LW
1284 case OP_AELEM:
1285 case OP_HELEM:
11343788 1286 ref(cBINOPo->op_first, o->op_type);
68dc0745 1287 if (type == OP_ENTERSUB &&
5dc0d613
MB
1288 !(o->op_private & (OPpLVAL_INTRO | OPpDEREF)))
1289 o->op_private |= OPpLVAL_DEFER;
78f9721b
SM
1290 if (type == OP_LEAVESUBLV)
1291 o->op_private |= OPpMAYBE_LVSUB;
ddeae0f1 1292 localize = 1;
3280af22 1293 PL_modcount++;
463ee0b2
LW
1294 break;
1295
1296 case OP_SCOPE:
1297 case OP_LEAVE:
1298 case OP_ENTER:
78f9721b 1299 case OP_LINESEQ:
ddeae0f1 1300 localize = 0;
11343788
MB
1301 if (o->op_flags & OPf_KIDS)
1302 mod(cLISTOPo->op_last, type);
a0d0e21e
LW
1303 break;
1304
1305 case OP_NULL:
ddeae0f1 1306 localize = 0;
638bc118
GS
1307 if (o->op_flags & OPf_SPECIAL) /* do BLOCK */
1308 goto nomod;
1309 else if (!(o->op_flags & OPf_KIDS))
463ee0b2 1310 break;
11343788
MB
1311 if (o->op_targ != OP_LIST) {
1312 mod(cBINOPo->op_first, type);
a0d0e21e
LW
1313 break;
1314 }
1315 /* FALL THROUGH */
463ee0b2 1316 case OP_LIST:
ddeae0f1 1317 localize = 0;
11343788 1318 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
463ee0b2
LW
1319 mod(kid, type);
1320 break;
78f9721b
SM
1321
1322 case OP_RETURN:
1323 if (type != OP_LEAVESUBLV)
1324 goto nomod;
1325 break; /* mod()ing was handled by ck_return() */
463ee0b2 1326 }
58d95175 1327
8be1be90
AMS
1328 /* [20011101.069] File test operators interpret OPf_REF to mean that
1329 their argument is a filehandle; thus \stat(".") should not set
1330 it. AMS 20011102 */
1331 if (type == OP_REFGEN &&
1332 PL_check[o->op_type] == MEMBER_TO_FPTR(Perl_ck_ftst))
1333 return o;
1334
1335 if (type != OP_LEAVESUBLV)
1336 o->op_flags |= OPf_MOD;
1337
1338 if (type == OP_AASSIGN || type == OP_SASSIGN)
1339 o->op_flags |= OPf_SPECIAL|OPf_REF;
ddeae0f1
DM
1340 else if (!type) { /* local() */
1341 switch (localize) {
1342 case 1:
1343 o->op_private |= OPpLVAL_INTRO;
1344 o->op_flags &= ~OPf_SPECIAL;
1345 PL_hints |= HINT_BLOCK_SCOPE;
1346 break;
1347 case 0:
1348 break;
1349 case -1:
1350 if (ckWARN(WARN_SYNTAX)) {
1351 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1352 "Useless localization of %s", OP_DESC(o));
1353 }
1354 }
463ee0b2 1355 }
8be1be90
AMS
1356 else if (type != OP_GREPSTART && type != OP_ENTERSUB
1357 && type != OP_LEAVESUBLV)
1358 o->op_flags |= OPf_REF;
11343788 1359 return o;
463ee0b2
LW
1360}
1361
864dbfa3 1362STATIC bool
5f66b61c 1363S_scalar_mod_type(const OP *o, I32 type)
3fe9a6f1 1364{
1365 switch (type) {
1366 case OP_SASSIGN:
5196be3e 1367 if (o->op_type == OP_RV2GV)
3fe9a6f1 1368 return FALSE;
1369 /* FALL THROUGH */
1370 case OP_PREINC:
1371 case OP_PREDEC:
1372 case OP_POSTINC:
1373 case OP_POSTDEC:
1374 case OP_I_PREINC:
1375 case OP_I_PREDEC:
1376 case OP_I_POSTINC:
1377 case OP_I_POSTDEC:
1378 case OP_POW:
1379 case OP_MULTIPLY:
1380 case OP_DIVIDE:
1381 case OP_MODULO:
1382 case OP_REPEAT:
1383 case OP_ADD:
1384 case OP_SUBTRACT:
1385 case OP_I_MULTIPLY:
1386 case OP_I_DIVIDE:
1387 case OP_I_MODULO:
1388 case OP_I_ADD:
1389 case OP_I_SUBTRACT:
1390 case OP_LEFT_SHIFT:
1391 case OP_RIGHT_SHIFT:
1392 case OP_BIT_AND:
1393 case OP_BIT_XOR:
1394 case OP_BIT_OR:
1395 case OP_CONCAT:
1396 case OP_SUBST:
1397 case OP_TRANS:
49e9fbe6
GS
1398 case OP_READ:
1399 case OP_SYSREAD:
1400 case OP_RECV:
bf4b1e52
GS
1401 case OP_ANDASSIGN:
1402 case OP_ORASSIGN:
3fe9a6f1 1403 return TRUE;
1404 default:
1405 return FALSE;
1406 }
1407}
1408
35cd451c 1409STATIC bool
5f66b61c 1410S_is_handle_constructor(const OP *o, I32 numargs)
35cd451c
GS
1411{
1412 switch (o->op_type) {
1413 case OP_PIPE_OP:
1414 case OP_SOCKPAIR:
504618e9 1415 if (numargs == 2)
35cd451c
GS
1416 return TRUE;
1417 /* FALL THROUGH */
1418 case OP_SYSOPEN:
1419 case OP_OPEN:
ded8aa31 1420 case OP_SELECT: /* XXX c.f. SelectSaver.pm */
35cd451c
GS
1421 case OP_SOCKET:
1422 case OP_OPEN_DIR:
1423 case OP_ACCEPT:
504618e9 1424 if (numargs == 1)
35cd451c 1425 return TRUE;
5f66b61c 1426 /* FALLTHROUGH */
35cd451c
GS
1427 default:
1428 return FALSE;
1429 }
1430}
1431
463ee0b2 1432OP *
864dbfa3 1433Perl_refkids(pTHX_ OP *o, I32 type)
463ee0b2 1434{
11343788 1435 if (o && o->op_flags & OPf_KIDS) {
6867be6d 1436 OP *kid;
11343788 1437 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
463ee0b2
LW
1438 ref(kid, type);
1439 }
11343788 1440 return o;
463ee0b2
LW
1441}
1442
1443OP *
e4c5ccf3 1444Perl_doref(pTHX_ OP *o, I32 type, bool set_op_ref)
463ee0b2 1445{
27da23d5 1446 dVAR;
463ee0b2 1447 OP *kid;
463ee0b2 1448
3280af22 1449 if (!o || PL_error_count)
11343788 1450 return o;
463ee0b2 1451
11343788 1452 switch (o->op_type) {
a0d0e21e 1453 case OP_ENTERSUB:
afebc493 1454 if ((type == OP_EXISTS || type == OP_DEFINED || type == OP_LOCK) &&
11343788
MB
1455 !(o->op_flags & OPf_STACKED)) {
1456 o->op_type = OP_RV2CV; /* entersub => rv2cv */
22c35a8c 1457 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
11343788 1458 assert(cUNOPo->op_first->op_type == OP_NULL);
93c66552 1459 op_null(((LISTOP*)cUNOPo->op_first)->op_first); /* disable pushmark */
11343788 1460 o->op_flags |= OPf_SPECIAL;
e26df76a 1461 o->op_private &= ~1;
8990e307
LW
1462 }
1463 break;
aeea060c 1464
463ee0b2 1465 case OP_COND_EXPR:
11343788 1466 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
e4c5ccf3 1467 doref(kid, type, set_op_ref);
463ee0b2 1468 break;
8990e307 1469 case OP_RV2SV:
35cd451c
GS
1470 if (type == OP_DEFINED)
1471 o->op_flags |= OPf_SPECIAL; /* don't create GV */
e4c5ccf3 1472 doref(cUNOPo->op_first, o->op_type, set_op_ref);
4633a7c4
LW
1473 /* FALL THROUGH */
1474 case OP_PADSV:
5f05dabc 1475 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
5dc0d613
MB
1476 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1477 : type == OP_RV2HV ? OPpDEREF_HV
1478 : OPpDEREF_SV);
11343788 1479 o->op_flags |= OPf_MOD;
a0d0e21e 1480 }
8990e307 1481 break;
1c846c1f 1482
2faa37cc 1483 case OP_THREADSV:
a863c7d1
MB
1484 o->op_flags |= OPf_MOD; /* XXX ??? */
1485 break;
1486
463ee0b2
LW
1487 case OP_RV2AV:
1488 case OP_RV2HV:
e4c5ccf3
RH
1489 if (set_op_ref)
1490 o->op_flags |= OPf_REF;
8990e307 1491 /* FALL THROUGH */
463ee0b2 1492 case OP_RV2GV:
35cd451c
GS
1493 if (type == OP_DEFINED)
1494 o->op_flags |= OPf_SPECIAL; /* don't create GV */
e4c5ccf3 1495 doref(cUNOPo->op_first, o->op_type, set_op_ref);
463ee0b2 1496 break;
8990e307 1497
463ee0b2
LW
1498 case OP_PADAV:
1499 case OP_PADHV:
e4c5ccf3
RH
1500 if (set_op_ref)
1501 o->op_flags |= OPf_REF;
79072805 1502 break;
aeea060c 1503
8990e307 1504 case OP_SCALAR:
79072805 1505 case OP_NULL:
11343788 1506 if (!(o->op_flags & OPf_KIDS))
463ee0b2 1507 break;
e4c5ccf3 1508 doref(cBINOPo->op_first, type, set_op_ref);
79072805
LW
1509 break;
1510 case OP_AELEM:
1511 case OP_HELEM:
e4c5ccf3 1512 doref(cBINOPo->op_first, o->op_type, set_op_ref);
5f05dabc 1513 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
5dc0d613
MB
1514 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1515 : type == OP_RV2HV ? OPpDEREF_HV
1516 : OPpDEREF_SV);
11343788 1517 o->op_flags |= OPf_MOD;
8990e307 1518 }
79072805
LW
1519 break;
1520
463ee0b2 1521 case OP_SCOPE:
79072805 1522 case OP_LEAVE:
e4c5ccf3
RH
1523 set_op_ref = FALSE;
1524 /* FALL THROUGH */
79072805 1525 case OP_ENTER:
8990e307 1526 case OP_LIST:
11343788 1527 if (!(o->op_flags & OPf_KIDS))
79072805 1528 break;
e4c5ccf3 1529 doref(cLISTOPo->op_last, type, set_op_ref);
79072805 1530 break;
a0d0e21e
LW
1531 default:
1532 break;
79072805 1533 }
11343788 1534 return scalar(o);
8990e307 1535
79072805
LW
1536}
1537
09bef843
SB
1538STATIC OP *
1539S_dup_attrlist(pTHX_ OP *o)
1540{
97aff369 1541 dVAR;
0bd48802 1542 OP *rop;
09bef843
SB
1543
1544 /* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
1545 * where the first kid is OP_PUSHMARK and the remaining ones
1546 * are OP_CONST. We need to push the OP_CONST values.
1547 */
1548 if (o->op_type == OP_CONST)
1549 rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc(cSVOPo->op_sv));
1550 else {
1551 assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
5f66b61c 1552 rop = NULL;
09bef843
SB
1553 for (o = cLISTOPo->op_first; o; o=o->op_sibling) {
1554 if (o->op_type == OP_CONST)
1555 rop = append_elem(OP_LIST, rop,
1556 newSVOP(OP_CONST, o->op_flags,
1557 SvREFCNT_inc(cSVOPo->op_sv)));
1558 }
1559 }
1560 return rop;
1561}
1562
1563STATIC void
95f0a2f1 1564S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs, bool for_my)
09bef843 1565{
27da23d5 1566 dVAR;
09bef843
SB
1567 SV *stashsv;
1568
1569 /* fake up C<use attributes $pkg,$rv,@attrs> */
1570 ENTER; /* need to protect against side-effects of 'use' */
1571 SAVEINT(PL_expect);
5aaec2b4 1572 stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
e4783991 1573
09bef843 1574#define ATTRSMODULE "attributes"
95f0a2f1
SB
1575#define ATTRSMODULE_PM "attributes.pm"
1576
1577 if (for_my) {
95f0a2f1 1578 /* Don't force the C<use> if we don't need it. */
a4fc7abc 1579 SV * const * const svp = hv_fetchs(GvHVn(PL_incgv), ATTRSMODULE_PM, FALSE);
95f0a2f1 1580 if (svp && *svp != &PL_sv_undef)
bb263b4e 1581 /*EMPTY*/; /* already in %INC */
95f0a2f1
SB
1582 else
1583 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
6136c704 1584 newSVpvs(ATTRSMODULE), NULL);
95f0a2f1
SB
1585 }
1586 else {
1587 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
6136c704
AL
1588 newSVpvs(ATTRSMODULE),
1589 NULL,
95f0a2f1
SB
1590 prepend_elem(OP_LIST,
1591 newSVOP(OP_CONST, 0, stashsv),
1592 prepend_elem(OP_LIST,
1593 newSVOP(OP_CONST, 0,
1594 newRV(target)),
1595 dup_attrlist(attrs))));
1596 }
09bef843
SB
1597 LEAVE;
1598}
1599
95f0a2f1
SB
1600STATIC void
1601S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp)
1602{
97aff369 1603 dVAR;
95f0a2f1
SB
1604 OP *pack, *imop, *arg;
1605 SV *meth, *stashsv;
1606
1607 if (!attrs)
1608 return;
1609
1610 assert(target->op_type == OP_PADSV ||
1611 target->op_type == OP_PADHV ||
1612 target->op_type == OP_PADAV);
1613
1614 /* Ensure that attributes.pm is loaded. */
dd2155a4 1615 apply_attrs(stash, PAD_SV(target->op_targ), attrs, TRUE);
95f0a2f1
SB
1616
1617 /* Need package name for method call. */
6136c704 1618 pack = newSVOP(OP_CONST, 0, newSVpvs(ATTRSMODULE));
95f0a2f1
SB
1619
1620 /* Build up the real arg-list. */
5aaec2b4
NC
1621 stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
1622
95f0a2f1
SB
1623 arg = newOP(OP_PADSV, 0);
1624 arg->op_targ = target->op_targ;
1625 arg = prepend_elem(OP_LIST,
1626 newSVOP(OP_CONST, 0, stashsv),
1627 prepend_elem(OP_LIST,
1628 newUNOP(OP_REFGEN, 0,
1629 mod(arg, OP_REFGEN)),
1630 dup_attrlist(attrs)));
1631
1632 /* Fake up a method call to import */
18916d0d 1633 meth = newSVpvs_share("import");
95f0a2f1
SB
1634 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL|OPf_WANT_VOID,
1635 append_elem(OP_LIST,
1636 prepend_elem(OP_LIST, pack, list(arg)),
1637 newSVOP(OP_METHOD_NAMED, 0, meth)));
1638 imop->op_private |= OPpENTERSUB_NOMOD;
1639
1640 /* Combine the ops. */
1641 *imopsp = append_elem(OP_LIST, *imopsp, imop);
1642}
1643
1644/*
1645=notfor apidoc apply_attrs_string
1646
1647Attempts to apply a list of attributes specified by the C<attrstr> and
1648C<len> arguments to the subroutine identified by the C<cv> argument which
1649is expected to be associated with the package identified by the C<stashpv>
1650argument (see L<attributes>). It gets this wrong, though, in that it
1651does not correctly identify the boundaries of the individual attribute
1652specifications within C<attrstr>. This is not really intended for the
1653public API, but has to be listed here for systems such as AIX which
1654need an explicit export list for symbols. (It's called from XS code
1655in support of the C<ATTRS:> keyword from F<xsubpp>.) Patches to fix it
1656to respect attribute syntax properly would be welcome.
1657
1658=cut
1659*/
1660
be3174d2 1661void
6867be6d
AL
1662Perl_apply_attrs_string(pTHX_ const char *stashpv, CV *cv,
1663 const char *attrstr, STRLEN len)
be3174d2 1664{
5f66b61c 1665 OP *attrs = NULL;
be3174d2
GS
1666
1667 if (!len) {
1668 len = strlen(attrstr);
1669 }
1670
1671 while (len) {
1672 for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
1673 if (len) {
890ce7af 1674 const char * const sstr = attrstr;
be3174d2
GS
1675 for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
1676 attrs = append_elem(OP_LIST, attrs,
1677 newSVOP(OP_CONST, 0,
1678 newSVpvn(sstr, attrstr-sstr)));
1679 }
1680 }
1681
1682 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
6136c704 1683 newSVpvs(ATTRSMODULE),
a0714e2c 1684 NULL, prepend_elem(OP_LIST,
be3174d2
GS
1685 newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
1686 prepend_elem(OP_LIST,
1687 newSVOP(OP_CONST, 0,
1688 newRV((SV*)cv)),
1689 attrs)));
1690}
1691
09bef843 1692STATIC OP *
95f0a2f1 1693S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp)
93a17b20 1694{
97aff369 1695 dVAR;
93a17b20
LW
1696 I32 type;
1697
3280af22 1698 if (!o || PL_error_count)
11343788 1699 return o;
93a17b20 1700
11343788 1701 type = o->op_type;
93a17b20 1702 if (type == OP_LIST) {
6867be6d 1703 OP *kid;
11343788 1704 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
95f0a2f1 1705 my_kid(kid, attrs, imopsp);
dab48698 1706 } else if (type == OP_UNDEF) {
7766148a 1707 return o;
77ca0c92
LW
1708 } else if (type == OP_RV2SV || /* "our" declaration */
1709 type == OP_RV2AV ||
1710 type == OP_RV2HV) { /* XXX does this let anything illegal in? */
1ce0b88c
RGS
1711 if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */
1712 yyerror(Perl_form(aTHX_ "Can't declare %s in %s",
1713 OP_DESC(o), PL_in_my == KEY_our ? "our" : "my"));
1714 } else if (attrs) {
551405c4 1715 GV * const gv = cGVOPx_gv(cUNOPo->op_first);
1ce0b88c 1716 PL_in_my = FALSE;
5c284bb0 1717 PL_in_my_stash = NULL;
1ce0b88c
RGS
1718 apply_attrs(GvSTASH(gv),
1719 (type == OP_RV2SV ? GvSV(gv) :
1720 type == OP_RV2AV ? (SV*)GvAV(gv) :
1721 type == OP_RV2HV ? (SV*)GvHV(gv) : (SV*)gv),
1722 attrs, FALSE);
1723 }
192587c2 1724 o->op_private |= OPpOUR_INTRO;
77ca0c92 1725 return o;
95f0a2f1
SB
1726 }
1727 else if (type != OP_PADSV &&
93a17b20
LW
1728 type != OP_PADAV &&
1729 type != OP_PADHV &&
1730 type != OP_PUSHMARK)
1731 {
eb64745e 1732 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
53e06cf0 1733 OP_DESC(o),
eb64745e 1734 PL_in_my == KEY_our ? "our" : "my"));
11343788 1735 return o;
93a17b20 1736 }
09bef843
SB
1737 else if (attrs && type != OP_PUSHMARK) {
1738 HV *stash;
09bef843 1739
eb64745e 1740 PL_in_my = FALSE;
5c284bb0 1741 PL_in_my_stash = NULL;
eb64745e 1742
09bef843 1743 /* check for C<my Dog $spot> when deciding package */
dd2155a4
DM
1744 stash = PAD_COMPNAME_TYPE(o->op_targ);
1745 if (!stash)
09bef843 1746 stash = PL_curstash;
95f0a2f1 1747 apply_attrs_my(stash, o, attrs, imopsp);
09bef843 1748 }
11343788
MB
1749 o->op_flags |= OPf_MOD;
1750 o->op_private |= OPpLVAL_INTRO;
1751 return o;
93a17b20
LW
1752}
1753
1754OP *
09bef843
SB
1755Perl_my_attrs(pTHX_ OP *o, OP *attrs)
1756{
97aff369 1757 dVAR;
0bd48802 1758 OP *rops;
95f0a2f1
SB
1759 int maybe_scalar = 0;
1760
d2be0de5 1761/* [perl #17376]: this appears to be premature, and results in code such as
c754c3d7 1762 C< our(%x); > executing in list mode rather than void mode */
d2be0de5 1763#if 0
09bef843
SB
1764 if (o->op_flags & OPf_PARENS)
1765 list(o);
95f0a2f1
SB
1766 else
1767 maybe_scalar = 1;
d2be0de5
YST
1768#else
1769 maybe_scalar = 1;
1770#endif
09bef843
SB
1771 if (attrs)
1772 SAVEFREEOP(attrs);
5f66b61c 1773 rops = NULL;
95f0a2f1
SB
1774 o = my_kid(o, attrs, &rops);
1775 if (rops) {
1776 if (maybe_scalar && o->op_type == OP_PADSV) {
1777 o = scalar(append_list(OP_LIST, (LISTOP*)rops, (LISTOP*)o));
1778 o->op_private |= OPpLVAL_INTRO;
1779 }
1780 else
1781 o = append_list(OP_LIST, (LISTOP*)o, (LISTOP*)rops);
1782 }
eb64745e 1783 PL_in_my = FALSE;
5c284bb0 1784 PL_in_my_stash = NULL;
eb64745e 1785 return o;
09bef843
SB
1786}
1787
1788OP *
1789Perl_my(pTHX_ OP *o)
1790{
5f66b61c 1791 return my_attrs(o, NULL);
09bef843
SB
1792}
1793
1794OP *
864dbfa3 1795Perl_sawparens(pTHX_ OP *o)
79072805 1796{
96a5add6 1797 PERL_UNUSED_CONTEXT;
79072805
LW
1798 if (o)
1799 o->op_flags |= OPf_PARENS;
1800 return o;
1801}
1802
1803OP *
864dbfa3 1804Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
79072805 1805{
11343788 1806 OP *o;
59f00321 1807 bool ismatchop = 0;
79072805 1808
041457d9 1809 if ( (left->op_type == OP_RV2AV ||
599cee73
PM
1810 left->op_type == OP_RV2HV ||
1811 left->op_type == OP_PADAV ||
041457d9
DM
1812 left->op_type == OP_PADHV)
1813 && ckWARN(WARN_MISC))
1814 {
551405c4 1815 const char * const desc = PL_op_desc[(right->op_type == OP_SUBST ||
599cee73
PM
1816 right->op_type == OP_TRANS)
1817 ? right->op_type : OP_MATCH];
551405c4 1818 const char * const sample = ((left->op_type == OP_RV2AV ||
dff6d3cd
GS
1819 left->op_type == OP_PADAV)
1820 ? "@array" : "%hash");
9014280d 1821 Perl_warner(aTHX_ packWARN(WARN_MISC),
1c846c1f 1822 "Applying %s to %s will act on scalar(%s)",
599cee73 1823 desc, sample, sample);
2ae324a7 1824 }
1825
5cc9e5c9
RH
1826 if (right->op_type == OP_CONST &&
1827 cSVOPx(right)->op_private & OPpCONST_BARE &&
1828 cSVOPx(right)->op_private & OPpCONST_STRICT)
1829 {
1830 no_bareword_allowed(right);
1831 }
1832
59f00321
RGS
1833 ismatchop = right->op_type == OP_MATCH ||
1834 right->op_type == OP_SUBST ||
1835 right->op_type == OP_TRANS;
1836 if (ismatchop && right->op_private & OPpTARGET_MY) {
1837 right->op_targ = 0;
1838 right->op_private &= ~OPpTARGET_MY;
1839 }
1840 if (!(right->op_flags & OPf_STACKED) && ismatchop) {
79072805 1841 right->op_flags |= OPf_STACKED;
6fbb66d6
NC
1842 if (right->op_type != OP_MATCH &&
1843 ! (right->op_type == OP_TRANS &&
1844 right->op_private & OPpTRANS_IDENTICAL))
463ee0b2 1845 left = mod(left, right->op_type);
79072805 1846 if (right->op_type == OP_TRANS)
11343788 1847 o = newBINOP(OP_NULL, OPf_STACKED, scalar(left), right);
79072805 1848 else
11343788 1849 o = prepend_elem(right->op_type, scalar(left), right);
79072805 1850 if (type == OP_NOT)
11343788
MB
1851 return newUNOP(OP_NOT, 0, scalar(o));
1852 return o;
79072805
LW
1853 }
1854 else
1855 return bind_match(type, left,
131b3ad0 1856 pmruntime(newPMOP(OP_MATCH, 0), right, 0));
79072805
LW
1857}
1858
1859OP *
864dbfa3 1860Perl_invert(pTHX_ OP *o)
79072805 1861{
11343788
MB
1862 if (!o)
1863 return o;
79072805 1864 /* XXX need to optimize away NOT NOT here? Or do we let optimizer do it? */
11343788 1865 return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
79072805
LW
1866}
1867
1868OP *
864dbfa3 1869Perl_scope(pTHX_ OP *o)
79072805 1870{
27da23d5 1871 dVAR;
79072805 1872 if (o) {
3280af22 1873 if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || PL_tainting) {
463ee0b2
LW
1874 o = prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
1875 o->op_type = OP_LEAVE;
22c35a8c 1876 o->op_ppaddr = PL_ppaddr[OP_LEAVE];
463ee0b2 1877 }
fdb22418
HS
1878 else if (o->op_type == OP_LINESEQ) {
1879 OP *kid;
1880 o->op_type = OP_SCOPE;
1881 o->op_ppaddr = PL_ppaddr[OP_SCOPE];
1882 kid = ((LISTOP*)o)->op_first;
59110972 1883 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
fdb22418 1884 op_null(kid);
59110972
RH
1885
1886 /* The following deals with things like 'do {1 for 1}' */
1887 kid = kid->op_sibling;
1888 if (kid &&
1889 (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE))
1890 op_null(kid);
1891 }
463ee0b2 1892 }
fdb22418 1893 else
5f66b61c 1894 o = newLISTOP(OP_SCOPE, 0, o, NULL);
79072805
LW
1895 }
1896 return o;
1897}
1898
a0d0e21e 1899int
864dbfa3 1900Perl_block_start(pTHX_ int full)
79072805 1901{
97aff369 1902 dVAR;
73d840c0 1903 const int retval = PL_savestack_ix;
dd2155a4 1904 pad_block_start(full);
b3ac6de7 1905 SAVEHINTS();
3280af22 1906 PL_hints &= ~HINT_BLOCK_SCOPE;
1c846c1f 1907 SAVESPTR(PL_compiling.cop_warnings);
0453d815 1908 if (! specialWARN(PL_compiling.cop_warnings)) {
599cee73
PM
1909 PL_compiling.cop_warnings = newSVsv(PL_compiling.cop_warnings) ;
1910 SAVEFREESV(PL_compiling.cop_warnings) ;
1911 }
ac27b0f5
NIS
1912 SAVESPTR(PL_compiling.cop_io);
1913 if (! specialCopIO(PL_compiling.cop_io)) {
1914 PL_compiling.cop_io = newSVsv(PL_compiling.cop_io) ;
1915 SAVEFREESV(PL_compiling.cop_io) ;
1916 }
a0d0e21e
LW
1917 return retval;
1918}
1919
1920OP*
864dbfa3 1921Perl_block_end(pTHX_ I32 floor, OP *seq)
a0d0e21e 1922{
97aff369 1923 dVAR;
6867be6d 1924 const int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
551405c4 1925 OP* const retval = scalarseq(seq);
e9818f4e 1926 LEAVE_SCOPE(floor);
eb160463 1927 PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
a0d0e21e 1928 if (needblockscope)
3280af22 1929 PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
dd2155a4 1930 pad_leavemy();
a0d0e21e
LW
1931 return retval;
1932}
1933
76e3520e 1934STATIC OP *
cea2e8a9 1935S_newDEFSVOP(pTHX)
54b9620d 1936{
97aff369 1937 dVAR;
6867be6d 1938 const I32 offset = pad_findmy("$_");
00b1698f 1939 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
59f00321
RGS
1940 return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
1941 }
1942 else {
551405c4 1943 OP * const o = newOP(OP_PADSV, 0);
59f00321
RGS
1944 o->op_targ = offset;
1945 return o;
1946 }
54b9620d
MB
1947}
1948
a0d0e21e 1949void
864dbfa3 1950Perl_newPROG(pTHX_ OP *o)
a0d0e21e 1951{
97aff369 1952 dVAR;
3280af22 1953 if (PL_in_eval) {
b295d113
TH
1954 if (PL_eval_root)
1955 return;
faef0170
HS
1956 PL_eval_root = newUNOP(OP_LEAVEEVAL,
1957 ((PL_in_eval & EVAL_KEEPERR)
1958 ? OPf_SPECIAL : 0), o);
3280af22 1959 PL_eval_start = linklist(PL_eval_root);
7934575e
GS
1960 PL_eval_root->op_private |= OPpREFCOUNTED;
1961 OpREFCNT_set(PL_eval_root, 1);
3280af22 1962 PL_eval_root->op_next = 0;
a2efc822 1963 CALL_PEEP(PL_eval_start);
a0d0e21e
LW
1964 }
1965 else {
6be89cf9
AE
1966 if (o->op_type == OP_STUB) {
1967 PL_comppad_name = 0;
1968 PL_compcv = 0;
2a4f803a 1969 FreeOp(o);
a0d0e21e 1970 return;
6be89cf9 1971 }
3280af22
NIS
1972 PL_main_root = scope(sawparens(scalarvoid(o)));
1973 PL_curcop = &PL_compiling;
1974 PL_main_start = LINKLIST(PL_main_root);
7934575e
GS
1975 PL_main_root->op_private |= OPpREFCOUNTED;
1976 OpREFCNT_set(PL_main_root, 1);
3280af22 1977 PL_main_root->op_next = 0;
a2efc822 1978 CALL_PEEP(PL_main_start);
3280af22 1979 PL_compcv = 0;
3841441e 1980
4fdae800 1981 /* Register with debugger */
84902520 1982 if (PERLDB_INTER) {
551405c4 1983 CV * const cv = get_cv("DB::postponed", FALSE);
3841441e
CS
1984 if (cv) {
1985 dSP;
924508f0 1986 PUSHMARK(SP);
cc49e20b 1987 XPUSHs((SV*)CopFILEGV(&PL_compiling));
3841441e 1988 PUTBACK;
864dbfa3 1989 call_sv((SV*)cv, G_DISCARD);
3841441e
CS
1990 }
1991 }
79072805 1992 }
79072805
LW
1993}
1994
1995OP *
864dbfa3 1996Perl_localize(pTHX_ OP *o, I32 lex)
79072805 1997{
97aff369 1998 dVAR;
79072805 1999 if (o->op_flags & OPf_PARENS)
d2be0de5
YST
2000/* [perl #17376]: this appears to be premature, and results in code such as
2001 C< our(%x); > executing in list mode rather than void mode */
2002#if 0
79072805 2003 list(o);
d2be0de5 2004#else
bb263b4e 2005 /*EMPTY*/;
d2be0de5 2006#endif
8990e307 2007 else {
041457d9
DM
2008 if ( PL_bufptr > PL_oldbufptr && PL_bufptr[-1] == ','
2009 && ckWARN(WARN_PARENTHESIS))
64420d0d
JH
2010 {
2011 char *s = PL_bufptr;
bac662ee 2012 bool sigil = FALSE;
64420d0d 2013
8473848f 2014 /* some heuristics to detect a potential error */
bac662ee 2015 while (*s && (strchr(", \t\n", *s)))
64420d0d 2016 s++;
8473848f 2017
bac662ee
TS
2018 while (1) {
2019 if (*s && strchr("@$%*", *s) && *++s
2020 && (isALNUM(*s) || UTF8_IS_CONTINUED(*s))) {
2021 s++;
2022 sigil = TRUE;
2023 while (*s && (isALNUM(*s) || UTF8_IS_CONTINUED(*s)))
2024 s++;
2025 while (*s && (strchr(", \t\n", *s)))
2026 s++;
2027 }
2028 else
2029 break;
2030 }
2031 if (sigil && (*s == ';' || *s == '=')) {
2032 Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS),
8473848f
RGS
2033 "Parentheses missing around \"%s\" list",
2034 lex ? (PL_in_my == KEY_our ? "our" : "my")
2035 : "local");
2036 }
8990e307
LW
2037 }
2038 }
93a17b20 2039 if (lex)
eb64745e 2040 o = my(o);
93a17b20 2041 else
eb64745e
GS
2042 o = mod(o, OP_NULL); /* a bit kludgey */
2043 PL_in_my = FALSE;
5c284bb0 2044 PL_in_my_stash = NULL;
eb64745e 2045 return o;
79072805
LW
2046}
2047
2048OP *
864dbfa3 2049Perl_jmaybe(pTHX_ OP *o)
79072805
LW
2050{
2051 if (o->op_type == OP_LIST) {
fafc274c
NC
2052 OP * const o2
2053 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpvs(";", GV_ADD|GV_NOTQUAL,
2054 SVt_PV)));
554b3eca 2055 o = convert(OP_JOIN, 0, prepend_elem(OP_LIST, o2, o));
79072805
LW
2056 }
2057 return o;
2058}
2059
2060OP *
864dbfa3 2061Perl_fold_constants(pTHX_ register OP *o)
79072805 2062{
27da23d5 2063 dVAR;
79072805
LW
2064 register OP *curop;
2065 I32 type = o->op_type;
748a9306 2066 SV *sv;
79072805 2067
22c35a8c 2068 if (PL_opargs[type] & OA_RETSCALAR)
79072805 2069 scalar(o);
b162f9ea 2070 if (PL_opargs[type] & OA_TARGET && !o->op_targ)
ed6116ce 2071 o->op_targ = pad_alloc(type, SVs_PADTMP);
79072805 2072
eac055e9
GS
2073 /* integerize op, unless it happens to be C<-foo>.
2074 * XXX should pp_i_negate() do magic string negation instead? */
2075 if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER)
2076 && !(type == OP_NEGATE && cUNOPo->op_first->op_type == OP_CONST
2077 && (cUNOPo->op_first->op_private & OPpCONST_BARE)))
2078 {
22c35a8c 2079 o->op_ppaddr = PL_ppaddr[type = ++(o->op_type)];
eac055e9 2080 }
85e6fe83 2081
22c35a8c 2082 if (!(PL_opargs[type] & OA_FOLDCONST))
79072805
LW
2083 goto nope;
2084
de939608 2085 switch (type) {
7a52d87a
GS
2086 case OP_NEGATE:
2087 /* XXX might want a ck_negate() for this */
2088 cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
2089 break;
de939608
CS
2090 case OP_UCFIRST:
2091 case OP_LCFIRST:
2092 case OP_UC:
2093 case OP_LC:
69dcf70c
MB
2094 case OP_SLT:
2095 case OP_SGT:
2096 case OP_SLE:
2097 case OP_SGE:
2098 case OP_SCMP:
2de3dbcc
JH
2099 /* XXX what about the numeric ops? */
2100 if (PL_hints & HINT_LOCALE)
de939608
CS
2101 goto nope;
2102 }
2103
3280af22 2104 if (PL_error_count)
a0d0e21e
LW
2105 goto nope; /* Don't try to run w/ errors */
2106
79072805 2107 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
11fa937b
GS
2108 if ((curop->op_type != OP_CONST ||
2109 (curop->op_private & OPpCONST_BARE)) &&
7a52d87a
GS
2110 curop->op_type != OP_LIST &&
2111 curop->op_type != OP_SCALAR &&
2112 curop->op_type != OP_NULL &&
2113 curop->op_type != OP_PUSHMARK)
2114 {
79072805
LW
2115 goto nope;
2116 }
2117 }
2118
2119 curop = LINKLIST(o);
2120 o->op_next = 0;
533c011a 2121 PL_op = curop;
cea2e8a9 2122 CALLRUNOPS(aTHX);
3280af22 2123 sv = *(PL_stack_sp--);
748a9306 2124 if (o->op_targ && sv == PAD_SV(o->op_targ)) /* grab pad temp? */
dd2155a4 2125 pad_swipe(o->op_targ, FALSE);
748a9306
LW
2126 else if (SvTEMP(sv)) { /* grab mortal temp? */
2127 (void)SvREFCNT_inc(sv);
2128 SvTEMP_off(sv);
85e6fe83 2129 }
79072805
LW
2130 op_free(o);
2131 if (type == OP_RV2GV)
b1cb66bf 2132 return newGVOP(OP_GV, 0, (GV*)sv);
52a96ae6 2133 return newSVOP(OP_CONST, 0, sv);
aeea060c 2134
79072805 2135 nope:
79072805
LW
2136 return o;
2137}
2138
2139OP *
864dbfa3 2140Perl_gen_constant_list(pTHX_ register OP *o)
79072805 2141{
27da23d5 2142 dVAR;
79072805 2143 register OP *curop;
6867be6d 2144 const I32 oldtmps_floor = PL_tmps_floor;
79072805 2145
a0d0e21e 2146 list(o);
3280af22 2147 if (PL_error_count)
a0d0e21e
LW
2148 return o; /* Don't attempt to run with errors */
2149
533c011a 2150 PL_op = curop = LINKLIST(o);
a0d0e21e 2151 o->op_next = 0;
a2efc822 2152 CALL_PEEP(curop);
cea2e8a9
GS
2153 pp_pushmark();
2154 CALLRUNOPS(aTHX);
533c011a 2155 PL_op = curop;
cea2e8a9 2156 pp_anonlist();
3280af22 2157 PL_tmps_floor = oldtmps_floor;
79072805
LW
2158
2159 o->op_type = OP_RV2AV;
22c35a8c 2160 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
fb53bbb2
SG
2161 o->op_flags &= ~OPf_REF; /* treat \(1..2) like an ordinary list */
2162 o->op_flags |= OPf_PARENS; /* and flatten \(1..2,3) */
2814eb74 2163 o->op_opt = 0; /* needs to be revisited in peep() */
79072805 2164 curop = ((UNOP*)o)->op_first;
3280af22 2165 ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, SvREFCNT_inc(*PL_stack_sp--));
79072805 2166 op_free(curop);
79072805
LW
2167 linklist(o);
2168 return list(o);
2169}
2170
2171OP *
864dbfa3 2172Perl_convert(pTHX_ I32 type, I32 flags, OP *o)
79072805 2173{
27da23d5 2174 dVAR;
11343788 2175 if (!o || o->op_type != OP_LIST)
5f66b61c 2176 o = newLISTOP(OP_LIST, 0, o, NULL);
748a9306 2177 else
5dc0d613 2178 o->op_flags &= ~OPf_WANT;
79072805 2179
22c35a8c 2180 if (!(PL_opargs[type] & OA_MARK))
93c66552 2181 op_null(cLISTOPo->op_first);
8990e307 2182
eb160463 2183 o->op_type = (OPCODE)type;
22c35a8c 2184 o->op_ppaddr = PL_ppaddr[type];
11343788 2185 o->op_flags |= flags;
79072805 2186
11343788 2187 o = CHECKOP(type, o);
fe2774ed 2188 if (o->op_type != (unsigned)type)
11343788 2189 return o;
79072805 2190
11343788 2191 return fold_constants(o);
79072805
LW
2192}
2193
2194/* List constructors */
2195
2196OP *
864dbfa3 2197Perl_append_elem(pTHX_ I32 type, OP *first, OP *last)
79072805
LW
2198{
2199 if (!first)
2200 return last;
8990e307
LW
2201
2202 if (!last)
79072805 2203 return first;
8990e307 2204
fe2774ed 2205 if (first->op_type != (unsigned)type
155aba94
GS
2206 || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
2207 {
2208 return newLISTOP(type, 0, first, last);
2209 }
79072805 2210
a0d0e21e
LW
2211 if (first->op_flags & OPf_KIDS)
2212 ((LISTOP*)first)->op_last->op_sibling = last;
2213 else {
2214 first->op_flags |= OPf_KIDS;
2215 ((LISTOP*)first)->op_first = last;
2216 }
2217 ((LISTOP*)first)->op_last = last;
a0d0e21e 2218 return first;
79072805
LW
2219}
2220
2221OP *
864dbfa3 2222Perl_append_list(pTHX_ I32 type, LISTOP *first, LISTOP *last)
79072805
LW
2223{
2224 if (!first)
2225 return (OP*)last;
8990e307
LW
2226
2227 if (!last)
79072805 2228 return (OP*)first;
8990e307 2229
fe2774ed 2230 if (first->op_type != (unsigned)type)
79072805 2231 return prepend_elem(type, (OP*)first, (OP*)last);
8990e307 2232
fe2774ed 2233 if (last->op_type != (unsigned)type)
79072805
LW
2234 return append_elem(type, (OP*)first, (OP*)last);
2235
2236 first->op_last->op_sibling = last->op_first;
2237 first->op_last = last->op_last;
117dada2 2238 first->op_flags |= (last->op_flags & OPf_KIDS);
1c846c1f 2239
238a4c30
NIS
2240 FreeOp(last);
2241
79072805
LW
2242 return (OP*)first;
2243}
2244
2245OP *
864dbfa3 2246Perl_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
79072805
LW
2247{
2248 if (!first)
2249 return last;
8990e307
LW
2250
2251 if (!last)
79072805 2252 return first;
8990e307 2253
fe2774ed 2254 if (last->op_type == (unsigned)type) {
8990e307
LW
2255 if (type == OP_LIST) { /* already a PUSHMARK there */
2256 first->op_sibling = ((LISTOP*)last)->op_first->op_sibling;
2257 ((LISTOP*)last)->op_first->op_sibling = first;
36a5d4ba
DC
2258 if (!(first->op_flags & OPf_PARENS))
2259 last->op_flags &= ~OPf_PARENS;
8990e307
LW
2260 }
2261 else {
2262 if (!(last->op_flags & OPf_KIDS)) {
2263 ((LISTOP*)last)->op_last = first;
2264 last->op_flags |= OPf_KIDS;
2265 }
2266 first->op_sibling = ((LISTOP*)last)->op_first;
2267 ((LISTOP*)last)->op_first = first;
79072805 2268 }
117dada2 2269 last->op_flags |= OPf_KIDS;
79072805
LW
2270 return last;
2271 }
2272
2273 return newLISTOP(type, 0, first, last);
2274}
2275
2276/* Constructors */
2277
2278OP *
864dbfa3 2279Perl_newNULLLIST(pTHX)
79072805 2280{
8990e307
LW
2281 return newOP(OP_STUB, 0);
2282}
2283
2284OP *
864dbfa3 2285Perl_force_list(pTHX_ OP *o)
8990e307 2286{
11343788 2287 if (!o || o->op_type != OP_LIST)
5f66b61c 2288 o = newLISTOP(OP_LIST, 0, o, NULL);
93c66552 2289 op_null(o);
11343788 2290 return o;
79072805
LW
2291}
2292
2293OP *
864dbfa3 2294Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
79072805 2295{
27da23d5 2296 dVAR;
79072805
LW
2297 LISTOP *listop;
2298
b7dc083c 2299 NewOp(1101, listop, 1, LISTOP);
79072805 2300
eb160463 2301 listop->op_type = (OPCODE)type;
22c35a8c 2302 listop->op_ppaddr = PL_ppaddr[type];
117dada2
SM
2303 if (first || last)
2304 flags |= OPf_KIDS;
eb160463 2305 listop->op_flags = (U8)flags;
79072805
LW
2306
2307 if (!last && first)
2308 last = first;
2309 else if (!first && last)
2310 first = last;
8990e307
LW
2311 else if (first)
2312 first->op_sibling = last;
79072805
LW
2313 listop->op_first = first;
2314 listop->op_last = last;
8990e307 2315 if (type == OP_LIST) {
551405c4 2316 OP* const pushop = newOP(OP_PUSHMARK, 0);
8990e307
LW
2317 pushop->op_sibling = first;
2318 listop->op_first = pushop;
2319 listop->op_flags |= OPf_KIDS;
2320 if (!last)
2321 listop->op_last = pushop;
2322 }
79072805 2323
463d09e6 2324 return CHECKOP(type, listop);
79072805
LW
2325}
2326
2327OP *
864dbfa3 2328Perl_newOP(pTHX_ I32 type, I32 flags)
79072805 2329{
27da23d5 2330 dVAR;
11343788 2331 OP *o;
b7dc083c 2332 NewOp(1101, o, 1, OP);
eb160463 2333 o->op_type = (OPCODE)type;
22c35a8c 2334 o->op_ppaddr = PL_ppaddr[type];
eb160463 2335 o->op_flags = (U8)flags;
79072805 2336
11343788 2337 o->op_next = o;
eb160463 2338 o->op_private = (U8)(0 | (flags >> 8));
22c35a8c 2339 if (PL_opargs[type] & OA_RETSCALAR)
11343788 2340 scalar(o);
22c35a8c 2341 if (PL_opargs[type] & OA_TARGET)
11343788
MB
2342 o->op_targ = pad_alloc(type, SVs_PADTMP);
2343 return CHECKOP(type, o);
79072805
LW
2344}
2345
2346OP *
864dbfa3 2347Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
79072805 2348{
27da23d5 2349 dVAR;
79072805
LW
2350 UNOP *unop;
2351
93a17b20 2352 if (!first)
aeea060c 2353 first = newOP(OP_STUB, 0);
22c35a8c 2354 if (PL_opargs[type] & OA_MARK)
8990e307 2355 first = force_list(first);
93a17b20 2356
b7dc083c 2357 NewOp(1101, unop, 1, UNOP);
eb160463 2358 unop->op_type = (OPCODE)type;
22c35a8c 2359 unop->op_ppaddr = PL_ppaddr[type];
79072805 2360 unop->op_first = first;
585ec06d 2361 unop->op_flags = (U8)(flags | OPf_KIDS);
eb160463 2362 unop->op_private = (U8)(1 | (flags >> 8));
e50aee73 2363 unop = (UNOP*) CHECKOP(type, unop);
79072805
LW
2364 if (unop->op_next)
2365 return (OP*)unop;
2366
a0d0e21e 2367 return fold_constants((OP *) unop);
79072805
LW
2368}
2369
2370OP *
864dbfa3 2371Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
79072805 2372{
27da23d5 2373 dVAR;
79072805 2374 BINOP *binop;
b7dc083c 2375 NewOp(1101, binop, 1, BINOP);
79072805
LW
2376
2377 if (!first)
2378 first = newOP(OP_NULL, 0);
2379
eb160463 2380 binop->op_type = (OPCODE)type;
22c35a8c 2381 binop->op_ppaddr = PL_ppaddr[type];
79072805 2382 binop->op_first = first;
585ec06d 2383 binop->op_flags = (U8)(flags | OPf_KIDS);
79072805
LW
2384 if (!last) {
2385 last = first;
eb160463 2386 binop->op_private = (U8)(1 | (flags >> 8));
79072805
LW
2387 }
2388 else {
eb160463 2389 binop->op_private = (U8)(2 | (flags >> 8));
79072805
LW
2390 first->op_sibling = last;
2391 }
2392
e50aee73 2393 binop = (BINOP*)CHECKOP(type, binop);
eb160463 2394 if (binop->op_next || binop->op_type != (OPCODE)type)
79072805
LW
2395 return (OP*)binop;
2396
7284ab6f 2397 binop->op_last = binop->op_first->op_sibling;
79072805 2398
a0d0e21e 2399 return fold_constants((OP *)binop);
79072805
LW
2400}
2401
5f66b61c
AL
2402static int uvcompare(const void *a, const void *b)
2403 __attribute__nonnull__(1)
2404 __attribute__nonnull__(2)
2405 __attribute__pure__;
abb2c242 2406static int uvcompare(const void *a, const void *b)
2b9d42f0 2407{
e1ec3a88 2408 if (*((const UV *)a) < (*(const UV *)b))
2b9d42f0 2409 return -1;
e1ec3a88 2410 if (*((const UV *)a) > (*(const UV *)b))
2b9d42f0 2411 return 1;
e1ec3a88 2412 if (*((const UV *)a+1) < (*(const UV *)b+1))
2b9d42f0 2413 return -1;
e1ec3a88 2414 if (*((const UV *)a+1) > (*(const UV *)b+1))
2b9d42f0 2415 return 1;
a0ed51b3
LW
2416 return 0;
2417}
2418
79072805 2419OP *
864dbfa3 2420Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
79072805 2421{
97aff369 2422 dVAR;
2d03de9c
AL
2423 SV * const tstr = ((SVOP*)expr)->op_sv;
2424 SV * const rstr = ((SVOP*)repl)->op_sv;
463ee0b2
LW
2425 STRLEN tlen;
2426 STRLEN rlen;
5c144d81
NC
2427 const U8 *t = (U8*)SvPV_const(tstr, tlen);
2428 const U8 *r = (U8*)SvPV_const(rstr, rlen);
79072805
LW
2429 register I32 i;
2430 register I32 j;
9b877dbb 2431 I32 grows = 0;
79072805
LW
2432 register short *tbl;
2433
551405c4
AL
2434 const I32 complement = o->op_private & OPpTRANS_COMPLEMENT;
2435 const I32 squash = o->op_private & OPpTRANS_SQUASH;
2436 I32 del = o->op_private & OPpTRANS_DELETE;
800b4dc4 2437 PL_hints |= HINT_BLOCK_SCOPE;
1c846c1f 2438
036b4402
GS
2439 if (SvUTF8(tstr))
2440 o->op_private |= OPpTRANS_FROM_UTF;
1c846c1f
NIS
2441
2442 if (SvUTF8(rstr))
036b4402 2443 o->op_private |= OPpTRANS_TO_UTF;
79072805 2444
a0ed51b3 2445 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
396482e1 2446 SV* const listsv = newSVpvs("# comment\n");
c445ea15 2447 SV* transv = NULL;
5c144d81
NC
2448 const U8* tend = t + tlen;
2449 const U8* rend = r + rlen;
ba210ebe 2450 STRLEN ulen;
84c133a0
RB
2451 UV tfirst = 1;
2452 UV tlast = 0;
2453 IV tdiff;
2454 UV rfirst = 1;
2455 UV rlast = 0;
2456 IV rdiff;
2457 IV diff;
a0ed51b3
LW
2458 I32 none = 0;
2459 U32 max = 0;
2460 I32 bits;
a0ed51b3 2461 I32 havefinal = 0;
9c5ffd7c 2462 U32 final = 0;
551405c4
AL
2463 const I32 from_utf = o->op_private & OPpTRANS_FROM_UTF;
2464 const I32 to_utf = o->op_private & OPpTRANS_TO_UTF;
bf4a1e57
JH
2465 U8* tsave = NULL;
2466 U8* rsave = NULL;
2467
2468 if (!from_utf) {
2469 STRLEN len = tlen;
5c144d81 2470 t = tsave = bytes_to_utf8(t, &len);
bf4a1e57
JH
2471 tend = t + len;
2472 }
2473 if (!to_utf && rlen) {
2474 STRLEN len = rlen;
5c144d81 2475 r = rsave = bytes_to_utf8(r, &len);
bf4a1e57
JH
2476 rend = r + len;
2477 }
a0ed51b3 2478
2b9d42f0
NIS
2479/* There are several snags with this code on EBCDIC:
2480 1. 0xFF is a legal UTF-EBCDIC byte (there are no illegal bytes).
2481 2. scan_const() in toke.c has encoded chars in native encoding which makes
2482 ranges at least in EBCDIC 0..255 range the bottom odd.
2483*/
2484
a0ed51b3 2485 if (complement) {
89ebb4a3 2486 U8 tmpbuf[UTF8_MAXBYTES+1];
2b9d42f0 2487 UV *cp;
a0ed51b3 2488 UV nextmin = 0;
a02a5408 2489 Newx(cp, 2*tlen, UV);
a0ed51b3 2490 i = 0;
396482e1 2491 transv = newSVpvs("");
a0ed51b3 2492 while (t < tend) {
2b9d42f0
NIS
2493 cp[2*i] = utf8n_to_uvuni(t, tend-t, &ulen, 0);
2494 t += ulen;
2495 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) {
a0ed51b3 2496 t++;
2b9d42f0
NIS
2497 cp[2*i+1] = utf8n_to_uvuni(t, tend-t, &ulen, 0);
2498 t += ulen;
a0ed51b3 2499 }
2b9d42f0
NIS
2500 else {
2501 cp[2*i+1] = cp[2*i];
2502 }
2503 i++;
a0ed51b3 2504 }
2b9d42f0 2505 qsort(cp, i, 2*sizeof(UV), uvcompare);
a0ed51b3 2506 for (j = 0; j < i; j++) {
2b9d42f0 2507 UV val = cp[2*j];
a0ed51b3
LW
2508 diff = val - nextmin;
2509 if (diff > 0) {
9041c2e3 2510 t = uvuni_to_utf8(tmpbuf,nextmin);
dfe13c55 2511 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
a0ed51b3 2512 if (diff > 1) {
2b9d42f0 2513 U8 range_mark = UTF_TO_NATIVE(0xff);
9041c2e3 2514 t = uvuni_to_utf8(tmpbuf, val - 1);
2b9d42f0 2515 sv_catpvn(transv, (char *)&range_mark, 1);
dfe13c55 2516 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
a0ed51b3
LW
2517 }
2518 }
2b9d42f0 2519 val = cp[2*j+1];
a0ed51b3
LW
2520 if (val >= nextmin)
2521 nextmin = val + 1;
2522 }
9041c2e3 2523 t = uvuni_to_utf8(tmpbuf,nextmin);
dfe13c55 2524 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2b9d42f0
NIS
2525 {
2526 U8 range_mark = UTF_TO_NATIVE(0xff);
2527 sv_catpvn(transv, (char *)&range_mark, 1);
2528 }
b851fbc1
JH
2529 t = uvuni_to_utf8_flags(tmpbuf, 0x7fffffff,
2530 UNICODE_ALLOW_SUPER);
dfe13c55 2531 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
93524f2b 2532 t = (const U8*)SvPVX_const(transv);
a0ed51b3
LW
2533 tlen = SvCUR(transv);
2534 tend = t + tlen;
455d824a 2535 Safefree(cp);
a0ed51b3
LW
2536 }
2537 else if (!rlen && !del) {
2538 r = t; rlen = tlen; rend = tend;
4757a243
LW
2539 }
2540 if (!squash) {
05d340b8 2541 if ((!rlen && !del) || t == r ||
12ae5dfc 2542 (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
01ec43d0 2543 {
4757a243 2544 o->op_private |= OPpTRANS_IDENTICAL;
01ec43d0 2545 }
a0ed51b3
LW
2546 }
2547
2548 while (t < tend || tfirst <= tlast) {
2549 /* see if we need more "t" chars */
2550 if (tfirst > tlast) {
9041c2e3 2551 tfirst = (I32)utf8n_to_uvuni(t, tend - t, &ulen, 0);
a0ed51b3 2552 t += ulen;
2b9d42f0 2553 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) { /* illegal utf8 val indicates range */
ba210ebe 2554 t++;
9041c2e3 2555 tlast = (I32)utf8n_to_uvuni(t, tend - t, &ulen, 0);
a0ed51b3
LW
2556 t += ulen;
2557 }
2558 else
2559 tlast = tfirst;
2560 }
2561
2562 /* now see if we need more "r" chars */
2563 if (rfirst > rlast) {
2564 if (r < rend) {
9041c2e3 2565 rfirst = (I32)utf8n_to_uvuni(r, rend - r, &ulen, 0);
a0ed51b3 2566 r += ulen;
2b9d42f0 2567 if (r < rend && NATIVE_TO_UTF(*r) == 0xff) { /* illegal utf8 val indicates range */
ba210ebe 2568 r++;
9041c2e3 2569 rlast = (I32)utf8n_to_uvuni(r, rend - r, &ulen, 0);
a0ed51b3
LW
2570 r += ulen;
2571 }
2572 else
2573 rlast = rfirst;
2574 }
2575 else {
2576 if (!havefinal++)
2577 final = rlast;
2578 rfirst = rlast = 0xffffffff;
2579 }
2580 }
2581
2582 /* now see which range will peter our first, if either. */
2583 tdiff = tlast - tfirst;
2584 rdiff = rlast - rfirst;
2585
2586 if (tdiff <= rdiff)
2587 diff = tdiff;
2588 else
2589 diff = rdiff;
2590
2591 if (rfirst == 0xffffffff) {
2592 diff = tdiff; /* oops, pretend rdiff is infinite */
2593 if (diff > 0)
894356b3
GS
2594 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
2595 (long)tfirst, (long)tlast);
a0ed51b3 2596 else
894356b3 2597 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
a0ed51b3
LW
2598 }
2599 else {
2600 if (diff > 0)
894356b3
GS
2601 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
2602 (long)tfirst, (long)(tfirst + diff),
2603 (long)rfirst);
a0ed51b3 2604 else
894356b3
GS
2605 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
2606 (long)tfirst, (long)rfirst);
a0ed51b3
LW
2607
2608 if (rfirst + diff > max)
2609 max = rfirst + diff;
9b877dbb 2610 if (!grows)
45005bfb
JH
2611 grows = (tfirst < rfirst &&
2612 UNISKIP(tfirst) < UNISKIP(rfirst + diff));
2613 rfirst += diff + 1;
a0ed51b3
LW
2614 }
2615 tfirst += diff + 1;
2616 }
2617
2618 none = ++max;
2619 if (del)
2620 del = ++max;
2621
2622 if (max > 0xffff)
2623 bits = 32;
2624 else if (max > 0xff)
2625 bits = 16;
2626 else
2627 bits = 8;
2628
455d824a 2629 Safefree(cPVOPo->op_pv);
a0ed51b3
LW
2630 cSVOPo->op_sv = (SV*)swash_init("utf8", "", listsv, bits, none);
2631 SvREFCNT_dec(listsv);
2632 if (transv)
2633 SvREFCNT_dec(transv);
2634
45005bfb 2635 if (!del && havefinal && rlen)
b448e4fe
JH
2636 (void)hv_store((HV*)SvRV((cSVOPo->op_sv)), "FINAL", 5,
2637 newSVuv((UV)final), 0);
a0ed51b3 2638
9b877dbb 2639 if (grows)
a0ed51b3
LW
2640 o->op_private |= OPpTRANS_GROWS;
2641
9b877dbb
IH
2642 if (tsave)
2643 Safefree(tsave);
2644 if (rsave)
2645 Safefree(rsave);
2646
a0ed51b3
LW
2647 op_free(expr);
2648 op_free(repl);
2649 return o;
2650 }
2651
2652 tbl = (short*)cPVOPo->op_pv;
79072805
LW
2653 if (complement) {
2654 Zero(tbl, 256, short);
eb160463 2655 for (i = 0; i < (I32)tlen; i++)
ec49126f 2656 tbl[t[i]] = -1;
79072805
LW
2657 for (i = 0, j = 0; i < 256; i++) {
2658 if (!tbl[i]) {
eb160463 2659 if (j >= (I32)rlen) {
a0ed51b3 2660 if (del)
79072805
LW
2661 tbl[i] = -2;
2662 else if (rlen)
ec49126f 2663 tbl[i] = r[j-1];
79072805 2664 else
eb160463 2665 tbl[i] = (short)i;
79072805 2666 }
9b877dbb
IH
2667 else {
2668 if (i < 128 && r[j] >= 128)
2669 grows = 1;
ec49126f 2670 tbl[i] = r[j++];
9b877dbb 2671 }
79072805
LW
2672 }
2673 }
05d340b8
JH
2674 if (!del) {
2675 if (!rlen) {
2676 j = rlen;
2677 if (!squash)
2678 o->op_private |= OPpTRANS_IDENTICAL;
2679 }
eb160463 2680 else if (j >= (I32)rlen)
05d340b8
JH
2681 j = rlen - 1;
2682 else
2683 cPVOPo->op_pv = (char*)Renew(tbl, 0x101+rlen-j, short);
585ec06d 2684 tbl[0x100] = (short)(rlen - j);
eb160463 2685 for (i=0; i < (I32)rlen - j; i++)
8973db79
JH
2686 tbl[0x101+i] = r[j+i];
2687 }
79072805
LW
2688 }
2689 else {
a0ed51b3 2690 if (!rlen && !del) {
79072805 2691 r = t; rlen = tlen;
5d06d08e 2692 if (!squash)
4757a243 2693 o->op_private |= OPpTRANS_IDENTICAL;
79072805 2694 }
94bfe852
RGS
2695 else if (!squash && rlen == tlen && memEQ((char*)t, (char*)r, tlen)) {
2696 o->op_private |= OPpTRANS_IDENTICAL;
2697 }
79072805
LW
2698 for (i = 0; i < 256; i++)
2699 tbl[i] = -1;
eb160463
GS
2700 for (i = 0, j = 0; i < (I32)tlen; i++,j++) {
2701 if (j >= (I32)rlen) {
a0ed51b3 2702 if (del) {
ec49126f 2703 if (tbl[t[i]] == -1)
2704 tbl[t[i]] = -2;
79072805
LW
2705 continue;
2706 }
2707 --j;
2708 }
9b877dbb
IH
2709 if (tbl[t[i]] == -1) {
2710 if (t[i] < 128 && r[j] >= 128)
2711 grows = 1;
ec49126f 2712 tbl[t[i]] = r[j];
9b877dbb 2713 }
79072805
LW
2714 }
2715 }
9b877dbb
IH
2716 if (grows)
2717 o->op_private |= OPpTRANS_GROWS;
79072805
LW
2718 op_free(expr);
2719 op_free(repl);
2720
11343788 2721 return o;
79072805
LW
2722}
2723
2724OP *
864dbfa3 2725Perl_newPMOP(pTHX_ I32 type, I32 flags)
79072805 2726{
27da23d5 2727 dVAR;
79072805
LW
2728 PMOP *pmop;
2729
b7dc083c 2730 NewOp(1101, pmop, 1, PMOP);
eb160463 2731 pmop->op_type = (OPCODE)type;
22c35a8c 2732 pmop->op_ppaddr = PL_ppaddr[type];
eb160463
GS
2733 pmop->op_flags = (U8)flags;
2734 pmop->op_private = (U8)(0 | (flags >> 8));
79072805 2735
3280af22 2736 if (PL_hints & HINT_RE_TAINT)
b3eb6a9b 2737 pmop->op_pmpermflags |= PMf_RETAINT;
3280af22 2738 if (PL_hints & HINT_LOCALE)
b3eb6a9b
GS
2739 pmop->op_pmpermflags |= PMf_LOCALE;
2740 pmop->op_pmflags = pmop->op_pmpermflags;
36477c24 2741
debc9467 2742#ifdef USE_ITHREADS
551405c4
AL
2743 if (av_len((AV*) PL_regex_pad[0]) > -1) {
2744 SV * const repointer = av_pop((AV*)PL_regex_pad[0]);
2745 pmop->op_pmoffset = SvIV(repointer);
2746 SvREPADTMP_off(repointer);
2747 sv_setiv(repointer,0);
2748 } else {
2749 SV * const repointer = newSViv(0);
2750 av_push(PL_regex_padav,SvREFCNT_inc(repointer));
2751 pmop->op_pmoffset = av_len(PL_regex_padav);
2752 PL_regex_pad = AvARRAY(PL_regex_padav);
13137afc 2753 }
debc9467 2754#endif
1eb1540c 2755
1fcf4c12 2756 /* link into pm list */
3280af22 2757 if (type != OP_TRANS && PL_curstash) {
8d2f4536
NC
2758 MAGIC *mg = mg_find((SV*)PL_curstash, PERL_MAGIC_symtab);
2759
2760 if (!mg) {
2761 mg = sv_magicext((SV*)PL_curstash, 0, PERL_MAGIC_symtab, 0, 0, 0);
2762 }
2763 pmop->op_pmnext = (PMOP*)mg->mg_obj;
2764 mg->mg_obj = (SV*)pmop;
cb55de95 2765 PmopSTASH_set(pmop,PL_curstash);
79072805
LW
2766 }
2767
463d09e6 2768 return CHECKOP(type, pmop);
79072805
LW
2769}
2770
131b3ad0
DM
2771/* Given some sort of match op o, and an expression expr containing a
2772 * pattern, either compile expr into a regex and attach it to o (if it's
2773 * constant), or convert expr into a runtime regcomp op sequence (if it's
2774 * not)
2775 *
2776 * isreg indicates that the pattern is part of a regex construct, eg
2777 * $x =~ /pattern/ or split /pattern/, as opposed to $x =~ $pattern or
2778 * split "pattern", which aren't. In the former case, expr will be a list
2779 * if the pattern contains more than one term (eg /a$b/) or if it contains
2780 * a replacement, ie s/// or tr///.
2781 */
2782
79072805 2783OP *
131b3ad0 2784Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg)
79072805 2785{
27da23d5 2786 dVAR;
79072805
LW
2787 PMOP *pm;
2788 LOGOP *rcop;
ce862d02 2789 I32 repl_has_vars = 0;
5f66b61c 2790 OP* repl = NULL;
131b3ad0
DM
2791 bool reglist;
2792
2793 if (o->op_type == OP_SUBST || o->op_type == OP_TRANS) {
2794 /* last element in list is the replacement; pop it */
2795 OP* kid;
2796 repl = cLISTOPx(expr)->op_last;
2797 kid = cLISTOPx(expr)->op_first;
2798 while (kid->op_sibling != repl)
2799 kid = kid->op_sibling;
5f66b61c 2800 kid->op_sibling = NULL;
131b3ad0
DM
2801 cLISTOPx(expr)->op_last = kid;
2802 }
79072805 2803
131b3ad0
DM
2804 if (isreg && expr->op_type == OP_LIST &&
2805 cLISTOPx(expr)->op_first->op_sibling == cLISTOPx(expr)->op_last)
2806 {
2807 /* convert single element list to element */
0bd48802 2808 OP* const oe = expr;
131b3ad0 2809 expr = cLISTOPx(oe)->op_first->op_sibling;
5f66b61c
AL
2810 cLISTOPx(oe)->op_first->op_sibling = NULL;
2811 cLISTOPx(oe)->op_last = NULL;
131b3ad0
DM
2812 op_free(oe);
2813 }
2814
2815 if (o->op_type == OP_TRANS) {
11343788 2816 return pmtrans(o, expr, repl);
131b3ad0
DM
2817 }
2818
2819 reglist = isreg && expr->op_type == OP_LIST;
2820 if (reglist)
2821 op_null(expr);
79072805 2822
3280af22 2823 PL_hints |= HINT_BLOCK_SCOPE;
11343788 2824 pm = (PMOP*)o;
79072805
LW
2825
2826 if (expr->op_type == OP_CONST) {
463ee0b2 2827 STRLEN plen;
6136c704 2828 SV * const pat = ((SVOP*)expr)->op_sv;
5c144d81 2829 const char *p = SvPV_const(pat, plen);
770526c1 2830 if ((o->op_flags & OPf_SPECIAL) && (*p == ' ' && p[1] == '\0')) {
5c144d81
NC
2831 U32 was_readonly = SvREADONLY(pat);
2832
2833 if (was_readonly) {
2834 if (SvFAKE(pat)) {
2835 sv_force_normal_flags(pat, 0);
2836 assert(!SvREADONLY(pat));
2837 was_readonly = 0;
2838 } else {
2839 SvREADONLY_off(pat);
2840 }
2841 }
2842
93a17b20 2843 sv_setpvn(pat, "\\s+", 3);
5c144d81
NC
2844
2845 SvFLAGS(pat) |= was_readonly;
2846
2847 p = SvPV_const(pat, plen);
79072805
LW
2848 pm->op_pmflags |= PMf_SKIPWHITE;
2849 }
5b71a6a7 2850 if (DO_UTF8(pat))
a5961de5 2851 pm->op_pmdynflags |= PMdf_UTF8;
5c144d81
NC
2852 /* FIXME - can we make this function take const char * args? */
2853 PM_SETRE(pm, CALLREGCOMP(aTHX_ (char*)p, (char*)p + plen, pm));
aaa362c4 2854 if (strEQ("\\s+", PM_GETRE(pm)->precomp))
85e6fe83 2855 pm->op_pmflags |= PMf_WHITE;
79072805
LW
2856 op_free(expr);
2857 }
2858 else {
3280af22 2859 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL))
1c846c1f 2860 expr = newUNOP((!(PL_hints & HINT_RE_EVAL)
2cd61cdb
IZ
2861 ? OP_REGCRESET
2862 : OP_REGCMAYBE),0,expr);
463ee0b2 2863
b7dc083c 2864 NewOp(1101, rcop, 1, LOGOP);
79072805 2865 rcop->op_type = OP_REGCOMP;
22c35a8c 2866 rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP];
79072805 2867 rcop->op_first = scalar(expr);
131b3ad0
DM
2868 rcop->op_flags |= OPf_KIDS
2869 | ((PL_hints & HINT_RE_EVAL) ? OPf_SPECIAL : 0)
2870 | (reglist ? OPf_STACKED : 0);
79072805 2871 rcop->op_private = 1;
11343788 2872 rcop->op_other = o;
131b3ad0
DM
2873 if (reglist)
2874 rcop->op_targ = pad_alloc(rcop->op_type, SVs_PADTMP);
2875
b5c19bd7
DM
2876 /* /$x/ may cause an eval, since $x might be qr/(?{..})/ */
2877 PL_cv_has_eval = 1;
79072805
LW
2878
2879 /* establish postfix order */
3280af22 2880 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL)) {
463ee0b2
LW
2881 LINKLIST(expr);
2882 rcop->op_next = expr;
2883 ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
2884 }
2885 else {
2886 rcop->op_next = LINKLIST(expr);
2887 expr->op_next = (OP*)rcop;
2888 }
79072805 2889
11343788 2890 prepend_elem(o->op_type, scalar((OP*)rcop), o);
79072805
LW
2891 }
2892
2893 if (repl) {
748a9306 2894 OP *curop;
0244c3a4 2895 if (pm->op_pmflags & PMf_EVAL) {
6136c704 2896 curop = NULL;
8bafa735 2897 if (CopLINE(PL_curcop) < (line_t)PL_multi_end)
eb160463 2898 CopLINE_set(PL_curcop, (line_t)PL_multi_end);
0244c3a4 2899 }
748a9306
LW
2900 else if (repl->op_type == OP_CONST)
2901 curop = repl;
79072805 2902 else {
c445ea15 2903 OP *lastop = NULL;
79072805 2904 for (curop = LINKLIST(repl); curop!=repl; curop = LINKLIST(curop)) {
22c35a8c 2905 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
79072805 2906 if (curop->op_type == OP_GV) {
6136c704 2907 GV * const gv = cGVOPx_gv(curop);
ce862d02 2908 repl_has_vars = 1;
f702bf4a 2909 if (strchr("&`'123456789+-\016\022", *GvENAME(gv)))
79072805
LW
2910 break;
2911 }
2912 else if (curop->op_type == OP_RV2CV)
2913 break;
2914 else if (curop->op_type == OP_RV2SV ||
2915 curop->op_type == OP_RV2AV ||
2916 curop->op_type == OP_RV2HV ||
2917 curop->op_type == OP_RV2GV) {
2918 if (lastop && lastop->op_type != OP_GV) /*funny deref?*/
2919 break;
2920 }
748a9306
LW
2921 else if (curop->op_type == OP_PADSV ||
2922 curop->op_type == OP_PADAV ||
2923 curop->op_type == OP_PADHV ||
554b3eca 2924 curop->op_type == OP_PADANY) {
ce862d02 2925 repl_has_vars = 1;
748a9306 2926 }
1167e5da 2927 else if (curop->op_type == OP_PUSHRE)
bb263b4e 2928 /*EMPTY*/; /* Okay here, dangerous in newASSIGNOP */
79072805
LW
2929 else
2930 break;
2931 }
2932 lastop = curop;
2933 }
748a9306 2934 }
ce862d02 2935 if (curop == repl
1c846c1f 2936 && !(repl_has_vars
aaa362c4
RS
2937 && (!PM_GETRE(pm)
2938 || PM_GETRE(pm)->reganch & ROPT_EVAL_SEEN))) {
748a9306 2939 pm->op_pmflags |= PMf_CONST; /* const for long enough */
4633a7c4 2940 pm->op_pmpermflags |= PMf_CONST; /* const for long enough */
11343788 2941 prepend_elem(o->op_type, scalar(repl), o);
748a9306
LW
2942 }
2943 else {
aaa362c4 2944 if (curop == repl && !PM_GETRE(pm)) { /* Has variables. */
ce862d02
IZ
2945 pm->op_pmflags |= PMf_MAYBE_CONST;
2946 pm->op_pmpermflags |= PMf_MAYBE_CONST;
2947 }
b7dc083c 2948 NewOp(1101, rcop, 1, LOGOP);
748a9306 2949 rcop->op_type = OP_SUBSTCONT;
22c35a8c 2950 rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT];
748a9306
LW
2951 rcop->op_first = scalar(repl);
2952 rcop->op_flags |= OPf_KIDS;
2953 rcop->op_private = 1;
11343788 2954 rcop->op_other = o;
748a9306
LW
2955
2956 /* establish postfix order */
2957 rcop->op_next = LINKLIST(repl);
2958 repl->op_next = (OP*)rcop;
2959
2960 pm->op_pmreplroot = scalar((OP*)rcop);
2961 pm->op_pmreplstart = LINKLIST(rcop);
2962 rcop->op_next = 0;
79072805
LW
2963 }
2964 }
2965
2966 return (OP*)pm;
2967}
2968
2969OP *
864dbfa3 2970Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
79072805 2971{
27da23d5 2972 dVAR;
79072805 2973 SVOP *svop;
b7dc083c 2974 NewOp(1101, svop, 1, SVOP);
eb160463 2975 svop->op_type = (OPCODE)type;
22c35a8c 2976 svop->op_ppaddr = PL_ppaddr[type];
79072805
LW
2977 svop->op_sv = sv;
2978 svop->op_next = (OP*)svop;
eb160463 2979 svop->op_flags = (U8)flags;
22c35a8c 2980 if (PL_opargs[type] & OA_RETSCALAR)
463ee0b2 2981 scalar((OP*)svop);
22c35a8c 2982 if (PL_opargs[type] & OA_TARGET)
ed6116ce 2983 svop->op_targ = pad_alloc(type, SVs_PADTMP);
e50aee73 2984 return CHECKOP(type, svop);
79072805
LW
2985}
2986
2987OP *
350de78d
GS
2988Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
2989{
27da23d5 2990 dVAR;
350de78d
GS
2991 PADOP *padop;
2992 NewOp(1101, padop, 1, PADOP);
eb160463 2993 padop->op_type = (OPCODE)type;
350de78d
GS
2994 padop->op_ppaddr = PL_ppaddr[type];
2995 padop->op_padix = pad_alloc(type, SVs_PADTMP);
dd2155a4
DM
2996 SvREFCNT_dec(PAD_SVl(padop->op_padix));
2997 PAD_SETSV(padop->op_padix, sv);
ce50c033
AMS
2998 if (sv)
2999 SvPADTMP_on(sv);
350de78d 3000 padop->op_next = (OP*)padop;
eb160463 3001 padop->op_flags = (U8)flags;
350de78d
GS
3002 if (PL_opargs[type] & OA_RETSCALAR)
3003 scalar((OP*)padop);
3004 if (PL_opargs[type] & OA_TARGET)
3005 padop->op_targ = pad_alloc(type, SVs_PADTMP);
3006 return CHECKOP(type, padop);
3007}
3008
3009OP *
864dbfa3 3010Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
79072805 3011{
27da23d5 3012 dVAR;
350de78d 3013#ifdef USE_ITHREADS
ce50c033
AMS
3014 if (gv)
3015 GvIN_PAD_on(gv);
350de78d
GS
3016 return newPADOP(type, flags, SvREFCNT_inc(gv));
3017#else
7934575e 3018 return newSVOP(type, flags, SvREFCNT_inc(gv));
350de78d 3019#endif
79072805
LW
3020}
3021
3022OP *
864dbfa3 3023Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
79072805 3024{
27da23d5 3025 dVAR;
79072805 3026 PVOP *pvop;
b7dc083c 3027 NewOp(1101, pvop, 1, PVOP);
eb160463 3028 pvop->op_type = (OPCODE)type;
22c35a8c 3029 pvop->op_ppaddr = PL_ppaddr[type];
79072805
LW
3030 pvop->op_pv = pv;
3031 pvop->op_next = (OP*)pvop;
eb160463 3032 pvop->op_flags = (U8)flags;
22c35a8c 3033 if (PL_opargs[type] & OA_RETSCALAR)
463ee0b2 3034 scalar((OP*)pvop);
22c35a8c 3035 if (PL_opargs[type] & OA_TARGET)
ed6116ce 3036 pvop->op_targ = pad_alloc(type, SVs_PADTMP);
e50aee73 3037 return CHECKOP(type, pvop);
79072805
LW
3038}
3039
79072805 3040void
864dbfa3 3041Perl_package(pTHX_ OP *o)
79072805 3042{
97aff369 3043 dVAR;
6867be6d 3044 const char *name;
de11ba31 3045 STRLEN len;
79072805 3046
3280af22
NIS
3047 save_hptr(&PL_curstash);
3048 save_item(PL_curstname);
de11ba31 3049
5c144d81 3050 name = SvPV_const(cSVOPo->op_sv, len);
de11ba31
AMS
3051 PL_curstash = gv_stashpvn(name, len, TRUE);
3052 sv_setpvn(PL_curstname, name, len);
3053 op_free(o);
3054
7ad382f4 3055 PL_hints |= HINT_BLOCK_SCOPE;
3280af22
NIS
3056 PL_copline = NOLINE;
3057 PL_expect = XSTATE;
79072805
LW
3058}
3059
85e6fe83 3060void
88d95a4d 3061Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg)
85e6fe83 3062{
97aff369 3063 dVAR;
a0d0e21e 3064 OP *pack;
a0d0e21e 3065 OP *imop;
b1cb66bf 3066 OP *veop;
85e6fe83 3067
88d95a4d 3068 if (idop->op_type != OP_CONST)
cea2e8a9 3069 Perl_croak(aTHX_ "Module name must be constant");
85e6fe83 3070
5f66b61c 3071 veop = NULL;
b1cb66bf 3072
aec46f14 3073 if (version) {
551405c4 3074 SV * const vesv = ((SVOP*)version)->op_sv;
b1cb66bf 3075
aec46f14 3076 if (!arg && !SvNIOKp(vesv)) {
b1cb66bf 3077 arg = version;
3078 }
3079 else {
3080 OP *pack;
0f79a09d 3081 SV *meth;
b1cb66bf 3082
44dcb63b 3083 if (version->op_type != OP_CONST || !SvNIOKp(vesv))
cea2e8a9 3084 Perl_croak(aTHX_ "Version number must be constant number");
b1cb66bf 3085
88d95a4d
JH
3086 /* Make copy of idop so we don't free it twice */
3087 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
b1cb66bf 3088
3089 /* Fake up a method call to VERSION */
18916d0d 3090 meth = newSVpvs_share("VERSION");
b1cb66bf 3091 veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3092 append_elem(OP_LIST,
0f79a09d
GS
3093 prepend_elem(OP_LIST, pack, list(version)),
3094 newSVOP(OP_METHOD_NAMED, 0, meth)));
b1cb66bf 3095 }
3096 }
aeea060c 3097
a0d0e21e 3098 /* Fake up an import/unimport */
4633a7c4
LW
3099 if (arg && arg->op_type == OP_STUB)
3100 imop = arg; /* no import on explicit () */
88d95a4d 3101 else if (SvNIOKp(((SVOP*)idop)->op_sv)) {
5f66b61c 3102 imop = NULL; /* use 5.0; */
468aa647
RGS
3103 if (!aver)
3104 idop->op_private |= OPpCONST_NOVER;
b1cb66bf 3105 }
4633a7c4 3106 else {
0f79a09d
GS
3107 SV *meth;
3108
88d95a4d
JH
3109 /* Make copy of idop so we don't free it twice */
3110 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
0f79a09d
GS
3111
3112 /* Fake up a method call to import/unimport */
427d62a4 3113 meth = aver
18916d0d 3114 ? newSVpvs_share("import") : newSVpvs_share("unimport");
4633a7c4 3115 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
0f79a09d
GS
3116 append_elem(OP_LIST,
3117 prepend_elem(OP_LIST, pack, list(arg)),
3118 newSVOP(OP_METHOD_NAMED, 0, meth)));
4633a7c4
LW
3119 }
3120
a0d0e21e 3121 /* Fake up the BEGIN {}, which does its thing immediately. */
09bef843 3122 newATTRSUB(floor,
18916d0d 3123 newSVOP(OP_CONST, 0, newSVpvs_share("BEGIN")),
5f66b61c
AL
3124 NULL,
3125 NULL,
a0d0e21e 3126 append_elem(OP_LINESEQ,
b1cb66bf 3127 append_elem(OP_LINESEQ,
bd61b366
SS
3128 newSTATEOP(0, NULL, newUNOP(OP_REQUIRE, 0, idop)),
3129 newSTATEOP(0, NULL, veop)),
3130 newSTATEOP(0, NULL, imop) ));
85e6fe83 3131
70f5e4ed
JH
3132 /* The "did you use incorrect case?" warning used to be here.
3133 * The problem is that on case-insensitive filesystems one
3134 * might get false positives for "use" (and "require"):
3135 * "use Strict" or "require CARP" will work. This causes
3136 * portability problems for the script: in case-strict
3137 * filesystems the script will stop working.
3138 *
3139 * The "incorrect case" warning checked whether "use Foo"
3140 * imported "Foo" to your namespace, but that is wrong, too:
3141 * there is no requirement nor promise in the language that
3142 * a Foo.pm should or would contain anything in package "Foo".
3143 *
3144 * There is very little Configure-wise that can be done, either:
3145 * the case-sensitivity of the build filesystem of Perl does not
3146 * help in guessing the case-sensitivity of the runtime environment.
3147 */
18fc9488 3148
c305c6a0 3149 PL_hints |= HINT_BLOCK_SCOPE;
3280af22
NIS
3150 PL_copline = NOLINE;
3151 PL_expect = XSTATE;
8ec8fbef 3152 PL_cop_seqmax++; /* Purely for B::*'s benefit */
85e6fe83
LW
3153}
3154
7d3fb230 3155/*
ccfc67b7
JH
3156=head1 Embedding Functions
3157
7d3fb230
BS
3158=for apidoc load_module
3159
3160Loads the module whose name is pointed to by the string part of name.
3161Note that the actual module name, not its filename, should be given.
3162Eg, "Foo::Bar" instead of "Foo/Bar.pm". flags can be any of
3163PERL_LOADMOD_DENY, PERL_LOADMOD_NOIMPORT, or PERL_LOADMOD_IMPORT_OPS
3164(or 0 for no flags). ver, if specified, provides version semantics
3165similar to C<use Foo::Bar VERSION>. The optional trailing SV*
3166arguments can be used to specify arguments to the module's import()
3167method, similar to C<use Foo::Bar VERSION LIST>.
3168
3169=cut */
3170
e4783991
GS
3171void
3172Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
3173{
3174 va_list args;
3175 va_start(args, ver);
3176 vload_module(flags, name, ver, &args);
3177 va_end(args);
3178}
3179
3180#ifdef PERL_IMPLICIT_CONTEXT
3181void
3182Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
3183{
3184 dTHX;
3185 va_list args;
3186 va_start(args, ver);
3187 vload_module(flags, name, ver, &args);
3188 va_end(args);
3189}
3190#endif
3191
3192void
3193Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
3194{
97aff369 3195 dVAR;
551405c4 3196 OP *veop, *imop;
e4783991 3197
551405c4 3198 OP * const modname = newSVOP(OP_CONST, 0, name);
e4783991
GS
3199 modname->op_private |= OPpCONST_BARE;
3200 if (ver) {
3201 veop = newSVOP(OP_CONST, 0, ver);
3202 }
3203 else
5f66b61c 3204 veop = NULL;
e4783991
GS
3205 if (flags & PERL_LOADMOD_NOIMPORT) {
3206 imop = sawparens(newNULLLIST());
3207 }
3208 else if (flags & PERL_LOADMOD_IMPORT_OPS) {
3209 imop = va_arg(*args, OP*);
3210 }
3211 else {
3212 SV *sv;
5f66b61c 3213 imop = NULL;
e4783991
GS
3214 sv = va_arg(*args, SV*);
3215 while (sv) {
3216 imop = append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
3217 sv = va_arg(*args, SV*);
3218 }
3219 }
81885997 3220 {
6867be6d
AL
3221 const line_t ocopline = PL_copline;
3222 COP * const ocurcop = PL_curcop;
3223 const int oexpect = PL_expect;
81885997
GS
3224
3225 utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
3226 veop, modname, imop);
3227 PL_expect = oexpect;
3228 PL_copline = ocopline;
834a3ffa 3229 PL_curcop = ocurcop;
81885997 3230 }
e4783991
GS
3231}
3232
79072805 3233OP *
850e8516 3234Perl_dofile(pTHX_ OP *term, I32 force_builtin)
78ca652e 3235{
97aff369 3236 dVAR;
78ca652e 3237 OP *doop;
a0714e2c 3238 GV *gv = NULL;
78ca652e 3239
850e8516 3240 if (!force_builtin) {
fafc274c 3241 gv = gv_fetchpvs("do", GV_NOTQUAL, SVt_PVCV);
850e8516 3242 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
a4fc7abc 3243 GV * const * const gvp = (GV**)hv_fetchs(PL_globalstash, "do", FALSE);
a0714e2c 3244 gv = gvp ? *gvp : NULL;
850e8516
RGS
3245 }
3246 }
78ca652e 3247
b9f751c0 3248 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
78ca652e
GS
3249 doop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
3250 append_elem(OP_LIST, term,
3251 scalar(newUNOP(OP_RV2CV, 0,
3252 newGVOP(OP_GV, 0,
3253 gv))))));
3254 }
3255 else {
3256 doop = newUNOP(OP_DOFILE, 0, scalar(term));
3257 }
3258 return doop;
3259}
3260
3261OP *
864dbfa3 3262Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
79072805
LW
3263{
3264 return newBINOP(OP_LSLICE, flags,
8990e307
LW
3265 list(force_list(subscript)),
3266 list(force_list(listval)) );
79072805
LW
3267}
3268
76e3520e 3269STATIC I32
504618e9 3270S_is_list_assignment(pTHX_ register const OP *o)
79072805 3271{
11343788 3272 if (!o)
79072805
LW
3273 return TRUE;
3274
11343788
MB
3275 if (o->op_type == OP_NULL && o->op_flags & OPf_KIDS)
3276 o = cUNOPo->op_first;
79072805 3277
11343788 3278 if (o->op_type == OP_COND_EXPR) {
504618e9
AL
3279 const I32 t = is_list_assignment(cLOGOPo->op_first->op_sibling);
3280 const I32 f = is_list_assignment(cLOGOPo->op_first->op_sibling->op_sibling);
79072805
LW
3281
3282 if (t && f)
3283 return TRUE;
3284 if (t || f)
3285 yyerror("Assignment to both a list and a scalar");
3286 return FALSE;
3287 }
3288
95f0a2f1
SB
3289 if (o->op_type == OP_LIST &&
3290 (o->op_flags & OPf_WANT) == OPf_WANT_SCALAR &&
3291 o->op_private & OPpLVAL_INTRO)
3292 return FALSE;
3293
11343788
MB
3294 if (o->op_type == OP_LIST || o->op_flags & OPf_PARENS ||
3295 o->op_type == OP_RV2AV || o->op_type == OP_RV2HV ||
3296 o->op_type == OP_ASLICE || o->op_type == OP_HSLICE)
79072805
LW
3297 return TRUE;
3298
11343788 3299 if (o->op_type == OP_PADAV || o->op_type == OP_PADHV)
93a17b20
LW
3300 return TRUE;
3301
11343788 3302 if (o->op_type == OP_RV2SV)
79072805
LW
3303 return FALSE;
3304
3305 return FALSE;
3306}
3307
3308OP *
864dbfa3 3309Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
79072805 3310{
97aff369 3311 dVAR;
11343788 3312 OP *o;
79072805 3313
a0d0e21e 3314 if (optype) {
c963b151 3315 if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN || optype == OP_DORASSIGN) {
a0d0e21e
LW
3316 return newLOGOP(optype, 0,
3317 mod(scalar(left), optype),
3318 newUNOP(OP_SASSIGN, 0, scalar(right)));
3319 }
3320 else {
3321 return newBINOP(optype, OPf_STACKED,
3322 mod(scalar(left), optype), scalar(right));
3323 }
3324 }
3325
504618e9 3326 if (is_list_assignment(left)) {
10c8fecd
GS
3327 OP *curop;
3328
3280af22 3329 PL_modcount = 0;
dbfe47cf
RD
3330 /* Grandfathering $[ assignment here. Bletch.*/
3331 /* Only simple assignments like C<< ($[) = 1 >> are allowed */
3332 PL_eval_start = (left->op_type == OP_CONST) ? right : 0;
463ee0b2 3333 left = mod(left, OP_AASSIGN);
3280af22
NIS
3334 if (PL_eval_start)
3335 PL_eval_start = 0;
dbfe47cf
RD
3336 else if (left->op_type == OP_CONST) {
3337 /* Result of assignment is always 1 (or we'd be dead already) */
3338 return newSVOP(OP_CONST, 0, newSViv(1));
a0d0e21e 3339 }
10c8fecd
GS
3340 curop = list(force_list(left));
3341 o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop);
eb160463 3342 o->op_private = (U8)(0 | (flags >> 8));
dd2155a4
DM
3343
3344 /* PL_generation sorcery:
3345 * an assignment like ($a,$b) = ($c,$d) is easier than
3346 * ($a,$b) = ($c,$a), since there is no need for temporary vars.
3347 * To detect whether there are common vars, the global var
3348 * PL_generation is incremented for each assign op we compile.
3349 * Then, while compiling the assign op, we run through all the
3350 * variables on both sides of the assignment, setting a spare slot
3351 * in each of them to PL_generation. If any of them already have
3352 * that value, we know we've got commonality. We could use a
3353 * single bit marker, but then we'd have to make 2 passes, first
3354 * to clear the flag, then to test and set it. To find somewhere
3355 * to store these values, evil chicanery is done with SvCUR().
3356 */
3357
a0d0e21e 3358 if (!(left->op_private & OPpLVAL_INTRO)) {
11343788 3359 OP *lastop = o;
3280af22 3360 PL_generation++;
11343788 3361 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
22c35a8c 3362 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
79072805 3363 if (curop->op_type == OP_GV) {
638eceb6 3364 GV *gv = cGVOPx_gv(curop);
169d2d72
NC
3365 if (gv == PL_defgv
3366 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
79072805 3367 break;
169d2d72 3368 GvASSIGN_GENERATION_set(gv, PL_generation);
79072805 3369 }
748a9306
LW
3370 else if (curop->op_type == OP_PADSV ||
3371 curop->op_type == OP_PADAV ||
3372 curop->op_type == OP_PADHV ||
dd2155a4
DM
3373 curop->op_type == OP_PADANY)
3374 {
3375 if (PAD_COMPNAME_GEN(curop->op_targ)
92251a1e 3376 == (STRLEN)PL_generation)
748a9306 3377 break;
b162af07 3378 PAD_COMPNAME_GEN_set(curop->op_targ, PL_generation);
dd2155a4 3379
748a9306 3380 }
79072805
LW
3381 else if (curop->op_type == OP_RV2CV)
3382 break;
3383 else if (curop->op_type == OP_RV2SV ||
3384 curop->op_type == OP_RV2AV ||
3385 curop->op_type == OP_RV2HV ||
3386 curop->op_type == OP_RV2GV) {
3387 if (lastop->op_type != OP_GV) /* funny deref? */
3388 break;
3389 }
1167e5da
SM
3390 else if (curop->op_type == OP_PUSHRE) {
3391 if (((PMOP*)curop)->op_pmreplroot) {
b3f5893f 3392#ifdef USE_ITHREADS
dd2155a4
DM
3393 GV *gv = (GV*)PAD_SVl(INT2PTR(PADOFFSET,
3394 ((PMOP*)curop)->op_pmreplroot));
b3f5893f 3395#else
1167e5da 3396 GV *gv = (GV*)((PMOP*)curop)->op_pmreplroot;
b3f5893f 3397#endif
169d2d72
NC
3398 if (gv == PL_defgv
3399 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
1167e5da 3400 break;
169d2d72
NC
3401 GvASSIGN_GENERATION_set(gv, PL_generation);
3402 GvASSIGN_GENERATION_set(gv, PL_generation);
b2ffa427 3403 }
1167e5da 3404 }
79072805
LW
3405 else
3406 break;
3407 }
3408 lastop = curop;
3409 }
11343788 3410 if (curop != o)
10c8fecd 3411 o->op_private |= OPpASSIGN_COMMON;
79072805 3412 }
c07a80fd 3413 if (right && right->op_type == OP_SPLIT) {
3414 OP* tmpop;
3415 if ((tmpop = ((LISTOP*)right)->op_first) &&
3416 tmpop->op_type == OP_PUSHRE)
3417 {
551405c4 3418 PMOP * const pm = (PMOP*)tmpop;
c07a80fd 3419 if (left->op_type == OP_RV2AV &&
3420 !(left->op_private & OPpLVAL_INTRO) &&
11343788 3421 !(o->op_private & OPpASSIGN_COMMON) )
c07a80fd 3422 {
3423 tmpop = ((UNOP*)left)->op_first;
3424 if (tmpop->op_type == OP_GV && !pm->op_pmreplroot) {
971a9dd3 3425#ifdef USE_ITHREADS
ba89bb6e 3426 pm->op_pmreplroot = INT2PTR(OP*, cPADOPx(tmpop)->op_padix);
971a9dd3
GS
3427 cPADOPx(tmpop)->op_padix = 0; /* steal it */
3428#else
3429 pm->op_pmreplroot = (OP*)cSVOPx(tmpop)->op_sv;
a0714e2c 3430 cSVOPx(tmpop)->op_sv = NULL; /* steal it */
971a9dd3 3431#endif
c07a80fd 3432 pm->op_pmflags |= PMf_ONCE;
11343788 3433 tmpop = cUNOPo->op_first; /* to list (nulled) */
c07a80fd 3434 tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
5f66b61c 3435 tmpop->op_sibling = NULL; /* don't free split */
c07a80fd 3436 right->op_next = tmpop->op_next; /* fix starting loc */
11343788 3437 op_free(o); /* blow off assign */
54310121 3438 right->op_flags &= ~OPf_WANT;
a5f75d66 3439 /* "I don't know and I don't care." */
c07a80fd 3440 return right;
3441 }
3442 }
3443 else {
e6438c1a 3444 if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
c07a80fd 3445 ((LISTOP*)right)->op_last->op_type == OP_CONST)
3446 {
3447 SV *sv = ((SVOP*)((LISTOP*)right)->op_last)->op_sv;
3448 if (SvIVX(sv) == 0)
3280af22 3449 sv_setiv(sv, PL_modcount+1);
c07a80fd 3450 }
3451 }
3452 }
3453 }
11343788 3454 return o;
79072805
LW
3455 }
3456 if (!right)
3457 right = newOP(OP_UNDEF, 0);
3458 if (right->op_type == OP_READLINE) {
3459 right->op_flags |= OPf_STACKED;
463ee0b2 3460 return newBINOP(OP_NULL, flags, mod(scalar(left), OP_SASSIGN), scalar(right));
79072805 3461 }
a0d0e21e 3462 else {
3280af22 3463 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
11343788 3464 o = newBINOP(OP_SASSIGN, flags,
463ee0b2 3465 scalar(right), mod(scalar(left), OP_SASSIGN) );
3280af22
NIS
3466 if (PL_eval_start)
3467 PL_eval_start = 0;
748a9306 3468 else {
dbfe47cf 3469 o = newSVOP(OP_CONST, 0, newSViv(PL_compiling.cop_arybase));
a0d0e21e
LW
3470 }
3471 }
11343788 3472 retur