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