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