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