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