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