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