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