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