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