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