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