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