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