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
Document new magic types in perlguts. Fix a comment about sort hints.
[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
b3ca2e83
NC		 76/* To implement user lexical pragams, there needs to be a way at run time to
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
84 leaf, ignoring any key you've already seen (placeholder or now), storing
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) {
7766f137 1106 PL_compiling.cop_arybase = (I32)SvIV(cSVOPx(PL_eval_start)->op_sv);
3280af22 1107 PL_eval_start = 0;
a0d0e21e
LW		 1108 }
1109 else if (!type) {
3280af22
NIS		 1110 SAVEI32(PL_compiling.cop_arybase);
1111 PL_compiling.cop_arybase = 0;
a0d0e21e
LW		 1112 }
1113 else if (type == OP_REFGEN)
1114 goto nomod;
1115 else
cea2e8a9 1116 Perl_croak(aTHX_ "That use of $[ is unsupported");
a0d0e21e 1117 break;
5f05dabc 1118 case OP_STUB:
eb8433b7 1119 if (o->op_flags & OPf_PARENS || PL_madskills)
5f05dabc 1120 break;
1121 goto nomod;
a0d0e21e
LW		 1122 case OP_ENTERSUB:
1123 if ((type == OP_UNDEF || type == OP_REFGEN) &&
11343788
MB		 1124 !(o->op_flags & OPf_STACKED)) {
1125 o->op_type = OP_RV2CV; /* entersub => rv2cv */
e26df76a
NC		 1126 /* The default is to set op_private to the number of children,
1127 which for a UNOP such as RV2CV is always 1. And w're using
1128 the bit for a flag in RV2CV, so we need it clear. */
1129 o->op_private &= ~1;
22c35a8c 1130 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
11343788 1131 assert(cUNOPo->op_first->op_type == OP_NULL);
93c66552 1132 op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
79072805
LW		 1133 break;
1134 }
95f0a2f1
SB		 1135 else if (o->op_private & OPpENTERSUB_NOMOD)
1136 return o;
cd06dffe
GS		 1137 else { /* lvalue subroutine call */
1138 o->op_private |= OPpLVAL_INTRO;
e6438c1a 1139 PL_modcount = RETURN_UNLIMITED_NUMBER;
4978d6d9 1140 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN) {
cd06dffe
GS		 1141 /* Backward compatibility mode: */
1142 o->op_private |= OPpENTERSUB_INARGS;
1143 break;
1144 }
1145 else { /* Compile-time error message: */
1146 OP *kid = cUNOPo->op_first;
1147 CV *cv;
1148 OP *okid;
1149
1150 if (kid->op_type == OP_PUSHMARK)
1151 goto skip_kids;
1152 if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
1153 Perl_croak(aTHX_
1154 "panic: unexpected lvalue entersub "
55140b79 1155 "args: type/targ %ld:%"UVuf,
3d811634 1156 (long)kid->op_type, (UV)kid->op_targ);
cd06dffe
GS		 1157 kid = kLISTOP->op_first;
1158 skip_kids:
1159 while (kid->op_sibling)
1160 kid = kid->op_sibling;
1161 if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) {
1162 /* Indirect call */
1163 if (kid->op_type == OP_METHOD_NAMED
1164 || kid->op_type == OP_METHOD)
1165 {
87d7fd28 1166 UNOP *newop;
b2ffa427 1167
87d7fd28 1168 NewOp(1101, newop, 1, UNOP);
349fd7b7
GS		 1169 newop->op_type = OP_RV2CV;
1170 newop->op_ppaddr = PL_ppaddr[OP_RV2CV];
5f66b61c 1171 newop->op_first = NULL;
87d7fd28
GS		 1172 newop->op_next = (OP*)newop;
1173 kid->op_sibling = (OP*)newop;
349fd7b7 1174 newop->op_private |= OPpLVAL_INTRO;
e26df76a 1175 newop->op_private &= ~1;
cd06dffe
GS		 1176 break;
1177 }
b2ffa427 1178
cd06dffe
GS		 1179 if (kid->op_type != OP_RV2CV)
1180 Perl_croak(aTHX_
1181 "panic: unexpected lvalue entersub "
55140b79 1182 "entry via type/targ %ld:%"UVuf,
3d811634 1183 (long)kid->op_type, (UV)kid->op_targ);
cd06dffe
GS		 1184 kid->op_private |= OPpLVAL_INTRO;
1185 break; /* Postpone until runtime */
1186 }
b2ffa427
NIS		 1187
1188 okid = kid;
cd06dffe
GS		 1189 kid = kUNOP->op_first;
1190 if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV)
1191 kid = kUNOP->op_first;
b2ffa427 1192 if (kid->op_type == OP_NULL)
cd06dffe
GS		 1193 Perl_croak(aTHX_
1194 "Unexpected constant lvalue entersub "
55140b79 1195 "entry via type/targ %ld:%"UVuf,
3d811634 1196 (long)kid->op_type, (UV)kid->op_targ);
cd06dffe
GS		 1197 if (kid->op_type != OP_GV) {
1198 /* Restore RV2CV to check lvalueness */
1199 restore_2cv:
1200 if (kid->op_next && kid->op_next != kid) { /* Happens? */
1201 okid->op_next = kid->op_next;
1202 kid->op_next = okid;
1203 }
1204 else
5f66b61c 1205 okid->op_next = NULL;
cd06dffe
GS		 1206 okid->op_type = OP_RV2CV;
1207 okid->op_targ = 0;
1208 okid->op_ppaddr = PL_ppaddr[OP_RV2CV];
1209 okid->op_private |= OPpLVAL_INTRO;
e26df76a 1210 okid->op_private &= ~1;
cd06dffe
GS		 1211 break;
1212 }
b2ffa427 1213
638eceb6 1214 cv = GvCV(kGVOP_gv);
1c846c1f 1215 if (!cv)
cd06dffe
GS		 1216 goto restore_2cv;
1217 if (CvLVALUE(cv))
1218 break;
1219 }
1220 }
79072805
LW		 1221 /* FALL THROUGH */
1222 default:
a0d0e21e 1223 nomod:
6fbb66d6
NC		 1224 /* grep, foreach, subcalls, refgen */
1225 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN)
a0d0e21e 1226 break;
cea2e8a9 1227 yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
638bc118 1228 (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
cd06dffe
GS		 1229 ? "do block"
1230 : (o->op_type == OP_ENTERSUB
1231 ? "non-lvalue subroutine call"
53e06cf0 1232 : OP_DESC(o))),
22c35a8c 1233 type ? PL_op_desc[type] : "local"));
11343788 1234 return o;
79072805 1235
a0d0e21e
LW		 1236 case OP_PREINC:
1237 case OP_PREDEC:
1238 case OP_POW:
1239 case OP_MULTIPLY:
1240 case OP_DIVIDE:
1241 case OP_MODULO:
1242 case OP_REPEAT:
1243 case OP_ADD:
1244 case OP_SUBTRACT:
1245 case OP_CONCAT:
1246 case OP_LEFT_SHIFT:
1247 case OP_RIGHT_SHIFT:
1248 case OP_BIT_AND:
1249 case OP_BIT_XOR:
1250 case OP_BIT_OR:
1251 case OP_I_MULTIPLY:
1252 case OP_I_DIVIDE:
1253 case OP_I_MODULO:
1254 case OP_I_ADD:
1255 case OP_I_SUBTRACT:
11343788 1256 if (!(o->op_flags & OPf_STACKED))
a0d0e21e 1257 goto nomod;
3280af22 1258 PL_modcount++;
a0d0e21e 1259 break;
b2ffa427 1260
79072805 1261 case OP_COND_EXPR:
ddeae0f1 1262 localize = 1;
11343788 1263 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
463ee0b2 1264 mod(kid, type);
79072805
LW		 1265 break;
1266
1267 case OP_RV2AV:
1268 case OP_RV2HV:
11343788 1269 if (type == OP_REFGEN && o->op_flags & OPf_PARENS) {
e6438c1a 1270 PL_modcount = RETURN_UNLIMITED_NUMBER;
11343788 1271 return o; /* Treat \(@foo) like ordinary list. */
748a9306
LW		 1272 }
1273 /* FALL THROUGH */
79072805 1274 case OP_RV2GV:
5dc0d613 1275 if (scalar_mod_type(o, type))
3fe9a6f1 1276 goto nomod;
11343788 1277 ref(cUNOPo->op_first, o->op_type);
79072805 1278 /* FALL THROUGH */
79072805
LW		 1279 case OP_ASLICE:
1280 case OP_HSLICE:
78f9721b
SM		 1281 if (type == OP_LEAVESUBLV)
1282 o->op_private |= OPpMAYBE_LVSUB;
ddeae0f1 1283 localize = 1;
78f9721b
SM		 1284 /* FALL THROUGH */
1285 case OP_AASSIGN:
93a17b20
LW		 1286 case OP_NEXTSTATE:
1287 case OP_DBSTATE:
e6438c1a 1288 PL_modcount = RETURN_UNLIMITED_NUMBER;
79072805 1289 break;
463ee0b2 1290 case OP_RV2SV:
aeea060c 1291 ref(cUNOPo->op_first, o->op_type);
ddeae0f1 1292 localize = 1;
463ee0b2 1293 /* FALL THROUGH */
79072805 1294 case OP_GV:
463ee0b2 1295 case OP_AV2ARYLEN:
3280af22 1296 PL_hints |= HINT_BLOCK_SCOPE;
463ee0b2 1297 case OP_SASSIGN:
bf4b1e52
GS		 1298 case OP_ANDASSIGN:
1299 case OP_ORASSIGN:
c963b151 1300 case OP_DORASSIGN:
ddeae0f1
DM		 1301 PL_modcount++;
1302 break;
1303
8990e307 1304 case OP_AELEMFAST:
6a077020 1305 localize = -1;
3280af22 1306 PL_modcount++;
8990e307
LW		 1307 break;
1308
748a9306
LW		 1309 case OP_PADAV:
1310 case OP_PADHV:
e6438c1a 1311 PL_modcount = RETURN_UNLIMITED_NUMBER;
5196be3e
MB		 1312 if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
1313 return o; /* Treat \(@foo) like ordinary list. */
1314 if (scalar_mod_type(o, type))
3fe9a6f1 1315 goto nomod;
78f9721b
SM		 1316 if (type == OP_LEAVESUBLV)
1317 o->op_private |= OPpMAYBE_LVSUB;
748a9306
LW		 1318 /* FALL THROUGH */
1319 case OP_PADSV:
3280af22 1320 PL_modcount++;
ddeae0f1 1321 if (!type) /* local() */
cea2e8a9 1322 Perl_croak(aTHX_ "Can't localize lexical variable %s",
dd2155a4 1323 PAD_COMPNAME_PV(o->op_targ));
463ee0b2
LW		 1324 break;
1325
748a9306 1326 case OP_PUSHMARK:
ddeae0f1 1327 localize = 0;
748a9306 1328 break;
b2ffa427 1329
69969c6f
SB		 1330 case OP_KEYS:
1331 if (type != OP_SASSIGN)
1332 goto nomod;
5d82c453
GA		 1333 goto lvalue_func;
1334 case OP_SUBSTR:
1335 if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */
1336 goto nomod;
5f05dabc 1337 /* FALL THROUGH */
a0d0e21e 1338 case OP_POS:
463ee0b2 1339 case OP_VEC:
78f9721b
SM		 1340 if (type == OP_LEAVESUBLV)
1341 o->op_private |= OPpMAYBE_LVSUB;
5d82c453 1342 lvalue_func:
11343788
MB		 1343 pad_free(o->op_targ);
1344 o->op_targ = pad_alloc(o->op_type, SVs_PADMY);
5dc0d613 1345 assert(SvTYPE(PAD_SV(o->op_targ)) == SVt_NULL);
11343788
MB		 1346 if (o->op_flags & OPf_KIDS)
1347 mod(cBINOPo->op_first->op_sibling, type);
463ee0b2 1348 break;
a0d0e21e 1349
463ee0b2
LW		 1350 case OP_AELEM:
1351 case OP_HELEM:
11343788 1352 ref(cBINOPo->op_first, o->op_type);
68dc0745 1353 if (type == OP_ENTERSUB &&
5dc0d613
MB		 1354 !(o->op_private & (OPpLVAL_INTRO | OPpDEREF)))
1355 o->op_private |= OPpLVAL_DEFER;
78f9721b
SM		 1356 if (type == OP_LEAVESUBLV)
1357 o->op_private |= OPpMAYBE_LVSUB;
ddeae0f1 1358 localize = 1;
3280af22 1359 PL_modcount++;
463ee0b2
LW		 1360 break;
1361
1362 case OP_SCOPE:
1363 case OP_LEAVE:
1364 case OP_ENTER:
78f9721b 1365 case OP_LINESEQ:
ddeae0f1 1366 localize = 0;
11343788
MB		 1367 if (o->op_flags & OPf_KIDS)
1368 mod(cLISTOPo->op_last, type);
a0d0e21e
LW		 1369 break;
1370
1371 case OP_NULL:
ddeae0f1 1372 localize = 0;
638bc118
GS		 1373 if (o->op_flags & OPf_SPECIAL) /* do BLOCK */
1374 goto nomod;
1375 else if (!(o->op_flags & OPf_KIDS))
463ee0b2 1376 break;
11343788
MB		 1377 if (o->op_targ != OP_LIST) {
1378 mod(cBINOPo->op_first, type);
a0d0e21e
LW		 1379 break;
1380 }
1381 /* FALL THROUGH */
463ee0b2 1382 case OP_LIST:
ddeae0f1 1383 localize = 0;
11343788 1384 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
463ee0b2
LW		 1385 mod(kid, type);
1386 break;
78f9721b
SM		 1387
1388 case OP_RETURN:
1389 if (type != OP_LEAVESUBLV)
1390 goto nomod;
1391 break; /* mod()ing was handled by ck_return() */
463ee0b2 1392 }
58d95175 1393
8be1be90
AMS		 1394 /* [20011101.069] File test operators interpret OPf_REF to mean that
1395 their argument is a filehandle; thus \stat(".") should not set
1396 it. AMS 20011102 */
1397 if (type == OP_REFGEN &&
1398 PL_check[o->op_type] == MEMBER_TO_FPTR(Perl_ck_ftst))
1399 return o;
1400
1401 if (type != OP_LEAVESUBLV)
1402 o->op_flags |= OPf_MOD;
1403
1404 if (type == OP_AASSIGN || type == OP_SASSIGN)
1405 o->op_flags |= OPf_SPECIAL|OPf_REF;
ddeae0f1
DM		 1406 else if (!type) { /* local() */
1407 switch (localize) {
1408 case 1:
1409 o->op_private |= OPpLVAL_INTRO;
1410 o->op_flags &= ~OPf_SPECIAL;
1411 PL_hints |= HINT_BLOCK_SCOPE;
1412 break;
1413 case 0:
1414 break;
1415 case -1:
1416 if (ckWARN(WARN_SYNTAX)) {
1417 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1418 "Useless localization of %s", OP_DESC(o));
1419 }
1420 }
463ee0b2 1421 }
8be1be90
AMS		 1422 else if (type != OP_GREPSTART && type != OP_ENTERSUB
1423 && type != OP_LEAVESUBLV)
1424 o->op_flags |= OPf_REF;
11343788 1425 return o;
463ee0b2
LW		 1426}
1427
864dbfa3 1428STATIC bool
5f66b61c 1429S_scalar_mod_type(const OP *o, I32 type)
3fe9a6f1 1430{
1431 switch (type) {
1432 case OP_SASSIGN:
5196be3e 1433 if (o->op_type == OP_RV2GV)
3fe9a6f1 1434 return FALSE;
1435 /* FALL THROUGH */
1436 case OP_PREINC:
1437 case OP_PREDEC:
1438 case OP_POSTINC:
1439 case OP_POSTDEC:
1440 case OP_I_PREINC:
1441 case OP_I_PREDEC:
1442 case OP_I_POSTINC:
1443 case OP_I_POSTDEC:
1444 case OP_POW:
1445 case OP_MULTIPLY:
1446 case OP_DIVIDE:
1447 case OP_MODULO:
1448 case OP_REPEAT:
1449 case OP_ADD:
1450 case OP_SUBTRACT:
1451 case OP_I_MULTIPLY:
1452 case OP_I_DIVIDE:
1453 case OP_I_MODULO:
1454 case OP_I_ADD:
1455 case OP_I_SUBTRACT:
1456 case OP_LEFT_SHIFT:
1457 case OP_RIGHT_SHIFT:
1458 case OP_BIT_AND:
1459 case OP_BIT_XOR:
1460 case OP_BIT_OR:
1461 case OP_CONCAT:
1462 case OP_SUBST:
1463 case OP_TRANS:
49e9fbe6
GS		 1464 case OP_READ:
1465 case OP_SYSREAD:
1466 case OP_RECV:
bf4b1e52
GS		 1467 case OP_ANDASSIGN:
1468 case OP_ORASSIGN:
3fe9a6f1 1469 return TRUE;
1470 default:
1471 return FALSE;
1472 }
1473}
1474
35cd451c 1475STATIC bool
5f66b61c 1476S_is_handle_constructor(const OP *o, I32 numargs)
35cd451c
GS		 1477{
1478 switch (o->op_type) {
1479 case OP_PIPE_OP:
1480 case OP_SOCKPAIR:
504618e9 1481 if (numargs == 2)
35cd451c
GS		 1482 return TRUE;
1483 /* FALL THROUGH */
1484 case OP_SYSOPEN:
1485 case OP_OPEN:
ded8aa31 1486 case OP_SELECT: /* XXX c.f. SelectSaver.pm */
35cd451c
GS		 1487 case OP_SOCKET:
1488 case OP_OPEN_DIR:
1489 case OP_ACCEPT:
504618e9 1490 if (numargs == 1)
35cd451c 1491 return TRUE;
5f66b61c 1492 /* FALLTHROUGH */
35cd451c
GS		 1493 default:
1494 return FALSE;
1495 }
1496}
1497
463ee0b2 1498OP *
864dbfa3 1499Perl_refkids(pTHX_ OP *o, I32 type)
463ee0b2 1500{
11343788 1501 if (o && o->op_flags & OPf_KIDS) {
6867be6d 1502 OP *kid;
11343788 1503 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
463ee0b2
LW		 1504 ref(kid, type);
1505 }
11343788 1506 return o;
463ee0b2
LW		 1507}
1508
1509OP *
e4c5ccf3 1510Perl_doref(pTHX_ OP *o, I32 type, bool set_op_ref)
463ee0b2 1511{
27da23d5 1512 dVAR;
463ee0b2 1513 OP *kid;
463ee0b2 1514
3280af22 1515 if (!o || PL_error_count)
11343788 1516 return o;
463ee0b2 1517
11343788 1518 switch (o->op_type) {
a0d0e21e 1519 case OP_ENTERSUB:
afebc493 1520 if ((type == OP_EXISTS || type == OP_DEFINED || type == OP_LOCK) &&
11343788
MB		 1521 !(o->op_flags & OPf_STACKED)) {
1522 o->op_type = OP_RV2CV; /* entersub => rv2cv */
22c35a8c 1523 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
11343788 1524 assert(cUNOPo->op_first->op_type == OP_NULL);
93c66552 1525 op_null(((LISTOP*)cUNOPo->op_first)->op_first); /* disable pushmark */
11343788 1526 o->op_flags |= OPf_SPECIAL;
e26df76a 1527 o->op_private &= ~1;
8990e307
LW		 1528 }
1529 break;
aeea060c 1530
463ee0b2 1531 case OP_COND_EXPR:
11343788 1532 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
e4c5ccf3 1533 doref(kid, type, set_op_ref);
463ee0b2 1534 break;
8990e307 1535 case OP_RV2SV:
35cd451c
GS		 1536 if (type == OP_DEFINED)
1537 o->op_flags |= OPf_SPECIAL; /* don't create GV */
e4c5ccf3 1538 doref(cUNOPo->op_first, o->op_type, set_op_ref);
4633a7c4
LW		 1539 /* FALL THROUGH */
1540 case OP_PADSV:
5f05dabc 1541 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
5dc0d613
MB		 1542 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1543 : type == OP_RV2HV ? OPpDEREF_HV
1544 : OPpDEREF_SV);
11343788 1545 o->op_flags |= OPf_MOD;
a0d0e21e 1546 }
8990e307 1547 break;
1c846c1f 1548
2faa37cc 1549 case OP_THREADSV:
a863c7d1
MB		 1550 o->op_flags |= OPf_MOD; /* XXX ??? */
1551 break;
1552
463ee0b2
LW		 1553 case OP_RV2AV:
1554 case OP_RV2HV:
e4c5ccf3
RH		 1555 if (set_op_ref)
1556 o->op_flags |= OPf_REF;
8990e307 1557 /* FALL THROUGH */
463ee0b2 1558 case OP_RV2GV:
35cd451c
GS		 1559 if (type == OP_DEFINED)
1560 o->op_flags |= OPf_SPECIAL; /* don't create GV */
e4c5ccf3 1561 doref(cUNOPo->op_first, o->op_type, set_op_ref);
463ee0b2 1562 break;
8990e307 1563
463ee0b2
LW		 1564 case OP_PADAV:
1565 case OP_PADHV:
e4c5ccf3
RH		 1566 if (set_op_ref)
1567 o->op_flags |= OPf_REF;
79072805 1568 break;
aeea060c 1569
8990e307 1570 case OP_SCALAR:
79072805 1571 case OP_NULL:
11343788 1572 if (!(o->op_flags & OPf_KIDS))
463ee0b2 1573 break;
e4c5ccf3 1574 doref(cBINOPo->op_first, type, set_op_ref);
79072805
LW		 1575 break;
1576 case OP_AELEM:
1577 case OP_HELEM:
e4c5ccf3 1578 doref(cBINOPo->op_first, o->op_type, set_op_ref);
5f05dabc 1579 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
5dc0d613
MB		 1580 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1581 : type == OP_RV2HV ? OPpDEREF_HV
1582 : OPpDEREF_SV);
11343788 1583 o->op_flags |= OPf_MOD;
8990e307 1584 }
79072805
LW		 1585 break;
1586
463ee0b2 1587 case OP_SCOPE:
79072805 1588 case OP_LEAVE:
e4c5ccf3
RH		 1589 set_op_ref = FALSE;
1590 /* FALL THROUGH */
79072805 1591 case OP_ENTER:
8990e307 1592 case OP_LIST:
11343788 1593 if (!(o->op_flags & OPf_KIDS))
79072805 1594 break;
e4c5ccf3 1595 doref(cLISTOPo->op_last, type, set_op_ref);
79072805 1596 break;
a0d0e21e
LW		 1597 default:
1598 break;
79072805 1599 }
11343788 1600 return scalar(o);
8990e307 1601
79072805
LW		 1602}
1603
09bef843
SB		 1604STATIC OP *
1605S_dup_attrlist(pTHX_ OP *o)
1606{
97aff369 1607 dVAR;
0bd48802 1608 OP *rop;
09bef843
SB		 1609
1610 /* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
1611 * where the first kid is OP_PUSHMARK and the remaining ones
1612 * are OP_CONST. We need to push the OP_CONST values.
1613 */
1614 if (o->op_type == OP_CONST)
b37c2d43 1615 rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc_NN(cSVOPo->op_sv));
eb8433b7
NC		 1616#ifdef PERL_MAD
1617 else if (o->op_type == OP_NULL)
1d866c12 1618 rop = NULL;
eb8433b7 1619#endif
09bef843
SB		 1620 else {
1621 assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
5f66b61c 1622 rop = NULL;
09bef843
SB		 1623 for (o = cLISTOPo->op_first; o; o=o->op_sibling) {
1624 if (o->op_type == OP_CONST)
1625 rop = append_elem(OP_LIST, rop,
1626 newSVOP(OP_CONST, o->op_flags,
b37c2d43 1627 SvREFCNT_inc_NN(cSVOPo->op_sv)));
09bef843
SB		 1628 }
1629 }
1630 return rop;
1631}
1632
1633STATIC void
95f0a2f1 1634S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs, bool for_my)
09bef843 1635{
27da23d5 1636 dVAR;
09bef843
SB		 1637 SV *stashsv;
1638
1639 /* fake up C<use attributes $pkg,$rv,@attrs> */
1640 ENTER; /* need to protect against side-effects of 'use' */
1641 SAVEINT(PL_expect);
5aaec2b4 1642 stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
e4783991 1643
09bef843 1644#define ATTRSMODULE "attributes"
95f0a2f1
SB		 1645#define ATTRSMODULE_PM "attributes.pm"
1646
1647 if (for_my) {
95f0a2f1 1648 /* Don't force the C<use> if we don't need it. */
a4fc7abc 1649 SV * const * const svp = hv_fetchs(GvHVn(PL_incgv), ATTRSMODULE_PM, FALSE);
95f0a2f1 1650 if (svp && *svp != &PL_sv_undef)
bb263b4e 1651 /*EMPTY*/; /* already in %INC */
95f0a2f1
SB		 1652 else
1653 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
6136c704 1654 newSVpvs(ATTRSMODULE), NULL);
95f0a2f1
SB		 1655 }
1656 else {
1657 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
6136c704
AL		 1658 newSVpvs(ATTRSMODULE),
1659 NULL,
95f0a2f1
SB		 1660 prepend_elem(OP_LIST,
1661 newSVOP(OP_CONST, 0, stashsv),
1662 prepend_elem(OP_LIST,
1663 newSVOP(OP_CONST, 0,
1664 newRV(target)),
1665 dup_attrlist(attrs))));
1666 }
09bef843
SB		 1667 LEAVE;
1668}
1669
95f0a2f1
SB		 1670STATIC void
1671S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp)
1672{
97aff369 1673 dVAR;
95f0a2f1
SB		 1674 OP *pack, *imop, *arg;
1675 SV *meth, *stashsv;
1676
1677 if (!attrs)
1678 return;
1679
1680 assert(target->op_type == OP_PADSV ||
1681 target->op_type == OP_PADHV ||
1682 target->op_type == OP_PADAV);
1683
1684 /* Ensure that attributes.pm is loaded. */
dd2155a4 1685 apply_attrs(stash, PAD_SV(target->op_targ), attrs, TRUE);
95f0a2f1
SB		 1686
1687 /* Need package name for method call. */
6136c704 1688 pack = newSVOP(OP_CONST, 0, newSVpvs(ATTRSMODULE));
95f0a2f1
SB		 1689
1690 /* Build up the real arg-list. */
5aaec2b4
NC		 1691 stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
1692
95f0a2f1
SB		 1693 arg = newOP(OP_PADSV, 0);
1694 arg->op_targ = target->op_targ;
1695 arg = prepend_elem(OP_LIST,
1696 newSVOP(OP_CONST, 0, stashsv),
1697 prepend_elem(OP_LIST,
1698 newUNOP(OP_REFGEN, 0,
1699 mod(arg, OP_REFGEN)),
1700 dup_attrlist(attrs)));
1701
1702 /* Fake up a method call to import */
18916d0d 1703 meth = newSVpvs_share("import");
95f0a2f1
SB		 1704 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL|OPf_WANT_VOID,
1705 append_elem(OP_LIST,
1706 prepend_elem(OP_LIST, pack, list(arg)),
1707 newSVOP(OP_METHOD_NAMED, 0, meth)));
1708 imop->op_private |= OPpENTERSUB_NOMOD;
1709
1710 /* Combine the ops. */
1711 *imopsp = append_elem(OP_LIST, *imopsp, imop);
1712}
1713
1714/*
1715=notfor apidoc apply_attrs_string
1716
1717Attempts to apply a list of attributes specified by the C<attrstr> and
1718C<len> arguments to the subroutine identified by the C<cv> argument which
1719is expected to be associated with the package identified by the C<stashpv>
1720argument (see L<attributes>). It gets this wrong, though, in that it
1721does not correctly identify the boundaries of the individual attribute
1722specifications within C<attrstr>. This is not really intended for the
1723public API, but has to be listed here for systems such as AIX which
1724need an explicit export list for symbols. (It's called from XS code
1725in support of the C<ATTRS:> keyword from F<xsubpp>.) Patches to fix it
1726to respect attribute syntax properly would be welcome.
1727
1728=cut
1729*/
1730
be3174d2 1731void
6867be6d
AL		 1732Perl_apply_attrs_string(pTHX_ const char *stashpv, CV *cv,
1733 const char *attrstr, STRLEN len)
be3174d2 1734{
5f66b61c 1735 OP *attrs = NULL;
be3174d2
GS		 1736
1737 if (!len) {
1738 len = strlen(attrstr);
1739 }
1740
1741 while (len) {
1742 for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
1743 if (len) {
890ce7af 1744 const char * const sstr = attrstr;
be3174d2
GS		 1745 for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
1746 attrs = append_elem(OP_LIST, attrs,
1747 newSVOP(OP_CONST, 0,
1748 newSVpvn(sstr, attrstr-sstr)));
1749 }
1750 }
1751
1752 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
6136c704 1753 newSVpvs(ATTRSMODULE),
a0714e2c 1754 NULL, prepend_elem(OP_LIST,
be3174d2
GS		 1755 newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
1756 prepend_elem(OP_LIST,
1757 newSVOP(OP_CONST, 0,
1758 newRV((SV*)cv)),
1759 attrs)));
1760}
1761
09bef843 1762STATIC OP *
95f0a2f1 1763S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp)
93a17b20 1764{
97aff369 1765 dVAR;
93a17b20
LW		 1766 I32 type;
1767
3280af22 1768 if (!o || PL_error_count)
11343788 1769 return o;
93a17b20 1770
bc61e325 1771 type = o->op_type;
eb8433b7
NC		 1772 if (PL_madskills && type == OP_NULL && o->op_flags & OPf_KIDS) {
1773 (void)my_kid(cUNOPo->op_first, attrs, imopsp);
1774 return o;
1775 }
1776
93a17b20 1777 if (type == OP_LIST) {
6867be6d 1778 OP *kid;
11343788 1779 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
95f0a2f1 1780 my_kid(kid, attrs, imopsp);
eb8433b7
NC		 1781 } else if (type == OP_UNDEF
1782#ifdef PERL_MAD
1783 || type == OP_STUB
1784#endif
1785 ) {
7766148a 1786 return o;
77ca0c92
LW		 1787 } else if (type == OP_RV2SV || /* "our" declaration */
1788 type == OP_RV2AV ||
1789 type == OP_RV2HV) { /* XXX does this let anything illegal in? */
1ce0b88c
RGS		 1790 if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */
1791 yyerror(Perl_form(aTHX_ "Can't declare %s in %s",
1792 OP_DESC(o), PL_in_my == KEY_our ? "our" : "my"));
1793 } else if (attrs) {
551405c4 1794 GV * const gv = cGVOPx_gv(cUNOPo->op_first);
1ce0b88c 1795 PL_in_my = FALSE;
5c284bb0 1796 PL_in_my_stash = NULL;
1ce0b88c
RGS		 1797 apply_attrs(GvSTASH(gv),
1798 (type == OP_RV2SV ? GvSV(gv) :
1799 type == OP_RV2AV ? (SV*)GvAV(gv) :
1800 type == OP_RV2HV ? (SV*)GvHV(gv) : (SV*)gv),
1801 attrs, FALSE);
1802 }
192587c2 1803 o->op_private |= OPpOUR_INTRO;
77ca0c92 1804 return o;
95f0a2f1
SB		 1805 }
1806 else if (type != OP_PADSV &&
93a17b20
LW		 1807 type != OP_PADAV &&
1808 type != OP_PADHV &&
1809 type != OP_PUSHMARK)
1810 {
eb64745e 1811 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
53e06cf0 1812 OP_DESC(o),
eb64745e 1813 PL_in_my == KEY_our ? "our" : "my"));
11343788 1814 return o;
93a17b20 1815 }
09bef843
SB		 1816 else if (attrs && type != OP_PUSHMARK) {
1817 HV *stash;
09bef843 1818
eb64745e 1819 PL_in_my = FALSE;
5c284bb0 1820 PL_in_my_stash = NULL;
eb64745e 1821
09bef843 1822 /* check for C<my Dog $spot> when deciding package */
dd2155a4
DM		 1823 stash = PAD_COMPNAME_TYPE(o->op_targ);
1824 if (!stash)
09bef843 1825 stash = PL_curstash;
95f0a2f1 1826 apply_attrs_my(stash, o, attrs, imopsp);
09bef843 1827 }
11343788
MB		 1828 o->op_flags |= OPf_MOD;
1829 o->op_private |= OPpLVAL_INTRO;
1830 return o;
93a17b20
LW		 1831}
1832
1833OP *
09bef843
SB		 1834Perl_my_attrs(pTHX_ OP *o, OP *attrs)
1835{
97aff369 1836 dVAR;
0bd48802 1837 OP *rops;
95f0a2f1
SB		 1838 int maybe_scalar = 0;
1839
d2be0de5 1840/* [perl #17376]: this appears to be premature, and results in code such as
c754c3d7 1841 C< our(%x); > executing in list mode rather than void mode */
d2be0de5 1842#if 0
09bef843
SB		 1843 if (o->op_flags & OPf_PARENS)
1844 list(o);
95f0a2f1
SB		 1845 else
1846 maybe_scalar = 1;
d2be0de5
YST		 1847#else
1848 maybe_scalar = 1;
1849#endif
09bef843
SB		 1850 if (attrs)
1851 SAVEFREEOP(attrs);
5f66b61c 1852 rops = NULL;
95f0a2f1
SB		 1853 o = my_kid(o, attrs, &rops);
1854 if (rops) {
1855 if (maybe_scalar && o->op_type == OP_PADSV) {
1856 o = scalar(append_list(OP_LIST, (LISTOP*)rops, (LISTOP*)o));
1857 o->op_private |= OPpLVAL_INTRO;
1858 }
1859 else
1860 o = append_list(OP_LIST, (LISTOP*)o, (LISTOP*)rops);
1861 }
eb64745e 1862 PL_in_my = FALSE;
5c284bb0 1863 PL_in_my_stash = NULL;
eb64745e 1864 return o;
09bef843
SB		 1865}
1866
1867OP *
1868Perl_my(pTHX_ OP *o)
1869{
5f66b61c 1870 return my_attrs(o, NULL);
09bef843
SB		 1871}
1872
1873OP *
864dbfa3 1874Perl_sawparens(pTHX_ OP *o)
79072805 1875{
96a5add6 1876 PERL_UNUSED_CONTEXT;
79072805
LW		 1877 if (o)
1878 o->op_flags |= OPf_PARENS;
1879 return o;
1880}
1881
1882OP *
864dbfa3 1883Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
79072805 1884{
11343788 1885 OP *o;
59f00321 1886 bool ismatchop = 0;
79072805 1887
041457d9 1888 if ( (left->op_type == OP_RV2AV ||
599cee73
PM		 1889 left->op_type == OP_RV2HV ||
1890 left->op_type == OP_PADAV ||
041457d9
DM		 1891 left->op_type == OP_PADHV)
1892 && ckWARN(WARN_MISC))
1893 {
551405c4 1894 const char * const desc = PL_op_desc[(right->op_type == OP_SUBST ||
599cee73
PM		 1895 right->op_type == OP_TRANS)
1896 ? right->op_type : OP_MATCH];
551405c4 1897 const char * const sample = ((left->op_type == OP_RV2AV ||
dff6d3cd
GS		 1898 left->op_type == OP_PADAV)
1899 ? "@array" : "%hash");
9014280d 1900 Perl_warner(aTHX_ packWARN(WARN_MISC),
1c846c1f 1901 "Applying %s to %s will act on scalar(%s)",
599cee73 1902 desc, sample, sample);
2ae324a7 1903 }
1904
5cc9e5c9
RH		 1905 if (right->op_type == OP_CONST &&
1906 cSVOPx(right)->op_private & OPpCONST_BARE &&
1907 cSVOPx(right)->op_private & OPpCONST_STRICT)
1908 {
1909 no_bareword_allowed(right);
1910 }
1911
59f00321
RGS		 1912 ismatchop = right->op_type == OP_MATCH ||
1913 right->op_type == OP_SUBST ||
1914 right->op_type == OP_TRANS;
1915 if (ismatchop && right->op_private & OPpTARGET_MY) {
1916 right->op_targ = 0;
1917 right->op_private &= ~OPpTARGET_MY;
1918 }
1919 if (!(right->op_flags & OPf_STACKED) && ismatchop) {
79072805 1920 right->op_flags |= OPf_STACKED;
6fbb66d6
NC		 1921 if (right->op_type != OP_MATCH &&
1922 ! (right->op_type == OP_TRANS &&
1923 right->op_private & OPpTRANS_IDENTICAL))
463ee0b2 1924 left = mod(left, right->op_type);
79072805 1925 if (right->op_type == OP_TRANS)
11343788 1926 o = newBINOP(OP_NULL, OPf_STACKED, scalar(left), right);
79072805 1927 else
11343788 1928 o = prepend_elem(right->op_type, scalar(left), right);
79072805 1929 if (type == OP_NOT)
11343788
MB		 1930 return newUNOP(OP_NOT, 0, scalar(o));
1931 return o;
79072805
LW		 1932 }
1933 else
1934 return bind_match(type, left,
131b3ad0 1935 pmruntime(newPMOP(OP_MATCH, 0), right, 0));
79072805
LW		 1936}
1937
1938OP *
864dbfa3 1939Perl_invert(pTHX_ OP *o)
79072805 1940{
11343788 1941 if (!o)
1d866c12 1942 return NULL;
11343788 1943 return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
79072805
LW		 1944}
1945
1946OP *
864dbfa3 1947Perl_scope(pTHX_ OP *o)
79072805 1948{
27da23d5 1949 dVAR;
79072805 1950 if (o) {
3280af22 1951 if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || PL_tainting) {
463ee0b2
LW		 1952 o = prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
1953 o->op_type = OP_LEAVE;
22c35a8c 1954 o->op_ppaddr = PL_ppaddr[OP_LEAVE];
463ee0b2 1955 }
fdb22418
HS		 1956 else if (o->op_type == OP_LINESEQ) {
1957 OP *kid;
1958 o->op_type = OP_SCOPE;
1959 o->op_ppaddr = PL_ppaddr[OP_SCOPE];
1960 kid = ((LISTOP*)o)->op_first;
59110972 1961 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
fdb22418 1962 op_null(kid);
59110972
RH		 1963
1964 /* The following deals with things like 'do {1 for 1}' */
1965 kid = kid->op_sibling;
1966 if (kid &&
1967 (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE))
1968 op_null(kid);
1969 }
463ee0b2 1970 }
fdb22418 1971 else
5f66b61c 1972 o = newLISTOP(OP_SCOPE, 0, o, NULL);
79072805
LW		 1973 }
1974 return o;
1975}
1976
a0d0e21e 1977int
864dbfa3 1978Perl_block_start(pTHX_ int full)
79072805 1979{
97aff369 1980 dVAR;
73d840c0 1981 const int retval = PL_savestack_ix;
dd2155a4 1982 pad_block_start(full);
b3ac6de7 1983 SAVEHINTS();
3280af22 1984 PL_hints &= ~HINT_BLOCK_SCOPE;
1c846c1f 1985 SAVESPTR(PL_compiling.cop_warnings);
0453d815 1986 if (! specialWARN(PL_compiling.cop_warnings)) {
599cee73
PM		 1987 PL_compiling.cop_warnings = newSVsv(PL_compiling.cop_warnings) ;
1988 SAVEFREESV(PL_compiling.cop_warnings) ;
1989 }
ac27b0f5
NIS		 1990 SAVESPTR(PL_compiling.cop_io);
1991 if (! specialCopIO(PL_compiling.cop_io)) {
1992 PL_compiling.cop_io = newSVsv(PL_compiling.cop_io) ;
1993 SAVEFREESV(PL_compiling.cop_io) ;
1994 }
a0d0e21e
LW		 1995 return retval;
1996}
1997
1998OP*
864dbfa3 1999Perl_block_end(pTHX_ I32 floor, OP *seq)
a0d0e21e 2000{
97aff369 2001 dVAR;
6867be6d 2002 const int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
551405c4 2003 OP* const retval = scalarseq(seq);
e9818f4e 2004 LEAVE_SCOPE(floor);
eb160463 2005 PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
a0d0e21e 2006 if (needblockscope)
3280af22 2007 PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
dd2155a4 2008 pad_leavemy();
a0d0e21e
LW		 2009 return retval;
2010}
2011
76e3520e 2012STATIC OP *
cea2e8a9 2013S_newDEFSVOP(pTHX)
54b9620d 2014{
97aff369 2015 dVAR;
6867be6d 2016 const I32 offset = pad_findmy("$_");
00b1698f 2017 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
59f00321
RGS		 2018 return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
2019 }
2020 else {
551405c4 2021 OP * const o = newOP(OP_PADSV, 0);
59f00321
RGS		 2022 o->op_targ = offset;
2023 return o;
2024 }
54b9620d
MB		 2025}
2026
a0d0e21e 2027void
864dbfa3 2028Perl_newPROG(pTHX_ OP *o)
a0d0e21e 2029{
97aff369 2030 dVAR;
3280af22 2031 if (PL_in_eval) {
b295d113
TH		 2032 if (PL_eval_root)
2033 return;
faef0170
HS		 2034 PL_eval_root = newUNOP(OP_LEAVEEVAL,
2035 ((PL_in_eval & EVAL_KEEPERR)
2036 ? OPf_SPECIAL : 0), o);
3280af22 2037 PL_eval_start = linklist(PL_eval_root);
7934575e
GS		 2038 PL_eval_root->op_private |= OPpREFCOUNTED;
2039 OpREFCNT_set(PL_eval_root, 1);
3280af22 2040 PL_eval_root->op_next = 0;
a2efc822 2041 CALL_PEEP(PL_eval_start);
a0d0e21e
LW		 2042 }
2043 else {
6be89cf9
AE		 2044 if (o->op_type == OP_STUB) {
2045 PL_comppad_name = 0;
2046 PL_compcv = 0;
2a4f803a 2047 FreeOp(o);
a0d0e21e 2048 return;
6be89cf9 2049 }
3280af22
NIS		 2050 PL_main_root = scope(sawparens(scalarvoid(o)));
2051 PL_curcop = &PL_compiling;
2052 PL_main_start = LINKLIST(PL_main_root);
7934575e
GS		 2053 PL_main_root->op_private |= OPpREFCOUNTED;
2054 OpREFCNT_set(PL_main_root, 1);
3280af22 2055 PL_main_root->op_next = 0;
a2efc822 2056 CALL_PEEP(PL_main_start);
3280af22 2057 PL_compcv = 0;
3841441e 2058
4fdae800 2059 /* Register with debugger */
84902520 2060 if (PERLDB_INTER) {
551405c4 2061 CV * const cv = get_cv("DB::postponed", FALSE);
3841441e
CS		 2062 if (cv) {
2063 dSP;
924508f0 2064 PUSHMARK(SP);
cc49e20b 2065 XPUSHs((SV*)CopFILEGV(&PL_compiling));
3841441e 2066 PUTBACK;
864dbfa3 2067 call_sv((SV*)cv, G_DISCARD);
3841441e
CS		 2068 }
2069 }
79072805 2070 }
79072805
LW		 2071}
2072
2073OP *
864dbfa3 2074Perl_localize(pTHX_ OP *o, I32 lex)
79072805 2075{
97aff369 2076 dVAR;
79072805 2077 if (o->op_flags & OPf_PARENS)
d2be0de5
YST		 2078/* [perl #17376]: this appears to be premature, and results in code such as
2079 C< our(%x); > executing in list mode rather than void mode */
2080#if 0
79072805 2081 list(o);
d2be0de5 2082#else
bb263b4e 2083 /*EMPTY*/;
d2be0de5 2084#endif
8990e307 2085 else {
041457d9
DM		 2086 if ( PL_bufptr > PL_oldbufptr && PL_bufptr[-1] == ','
2087 && ckWARN(WARN_PARENTHESIS))
64420d0d
JH		 2088 {
2089 char *s = PL_bufptr;
bac662ee 2090 bool sigil = FALSE;
64420d0d 2091
8473848f 2092 /* some heuristics to detect a potential error */
bac662ee 2093 while (*s && (strchr(", \t\n", *s)))
64420d0d 2094 s++;
8473848f 2095
bac662ee
TS		 2096 while (1) {
2097 if (*s && strchr("@$%*", *s) && *++s
2098 && (isALNUM(*s) || UTF8_IS_CONTINUED(*s))) {
2099 s++;
2100 sigil = TRUE;
2101 while (*s && (isALNUM(*s) || UTF8_IS_CONTINUED(*s)))
2102 s++;
2103 while (*s && (strchr(", \t\n", *s)))
2104 s++;
2105 }
2106 else
2107 break;
2108 }
2109 if (sigil && (*s == ';' || *s == '=')) {
2110 Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS),
8473848f
RGS		 2111 "Parentheses missing around \"%s\" list",
2112 lex ? (PL_in_my == KEY_our ? "our" : "my")
2113 : "local");
2114 }
8990e307
LW		 2115 }
2116 }
93a17b20 2117 if (lex)
eb64745e 2118 o = my(o);
93a17b20 2119 else
eb64745e
GS		 2120 o = mod(o, OP_NULL); /* a bit kludgey */
2121 PL_in_my = FALSE;
5c284bb0 2122 PL_in_my_stash = NULL;
eb64745e 2123 return o;
79072805
LW		 2124}
2125
2126OP *
864dbfa3 2127Perl_jmaybe(pTHX_ OP *o)
79072805
LW		 2128{
2129 if (o->op_type == OP_LIST) {
fafc274c 2130 OP * const o2
d4c19fe8 2131 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpvs(";", GV_ADD|GV_NOTQUAL, SVt_PV)));
554b3eca 2132 o = convert(OP_JOIN, 0, prepend_elem(OP_LIST, o2, o));
79072805
LW		 2133 }
2134 return o;
2135}
2136
2137OP *
864dbfa3 2138Perl_fold_constants(pTHX_ register OP *o)
79072805 2139{
27da23d5 2140 dVAR;
79072805 2141 register OP *curop;
eb8433b7 2142 OP *newop;
79072805 2143 I32 type = o->op_type;
748a9306 2144 SV *sv;
b7f7fd0b
NC		 2145 int ret = 0;
2146 I32 oldscope;
2147 OP *old_next;
2148 dJMPENV;
79072805 2149
22c35a8c 2150 if (PL_opargs[type] & OA_RETSCALAR)
79072805 2151 scalar(o);
b162f9ea 2152 if (PL_opargs[type] & OA_TARGET && !o->op_targ)
ed6116ce 2153 o->op_targ = pad_alloc(type, SVs_PADTMP);
79072805 2154
eac055e9
GS		 2155 /* integerize op, unless it happens to be C<-foo>.
2156 * XXX should pp_i_negate() do magic string negation instead? */
2157 if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER)
2158 && !(type == OP_NEGATE && cUNOPo->op_first->op_type == OP_CONST
2159 && (cUNOPo->op_first->op_private & OPpCONST_BARE)))
2160 {
22c35a8c 2161 o->op_ppaddr = PL_ppaddr[type = ++(o->op_type)];
eac055e9 2162 }
85e6fe83 2163
22c35a8c 2164 if (!(PL_opargs[type] & OA_FOLDCONST))
79072805
LW		 2165 goto nope;
2166
de939608 2167 switch (type) {
7a52d87a
GS		 2168 case OP_NEGATE:
2169 /* XXX might want a ck_negate() for this */
2170 cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
2171 break;
de939608
CS		 2172 case OP_UCFIRST:
2173 case OP_LCFIRST:
2174 case OP_UC:
2175 case OP_LC:
69dcf70c
MB		 2176 case OP_SLT:
2177 case OP_SGT:
2178 case OP_SLE:
2179 case OP_SGE:
2180 case OP_SCMP:
2de3dbcc
JH		 2181 /* XXX what about the numeric ops? */
2182 if (PL_hints & HINT_LOCALE)
de939608
CS		 2183 goto nope;
2184 }
2185
3280af22 2186 if (PL_error_count)
a0d0e21e
LW		 2187 goto nope; /* Don't try to run w/ errors */
2188
79072805 2189 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
11fa937b
GS		 2190 if ((curop->op_type != OP_CONST ||
2191 (curop->op_private & OPpCONST_BARE)) &&
7a52d87a
GS		 2192 curop->op_type != OP_LIST &&
2193 curop->op_type != OP_SCALAR &&
2194 curop->op_type != OP_NULL &&
2195 curop->op_type != OP_PUSHMARK)
2196 {
79072805
LW		 2197 goto nope;
2198 }
2199 }
2200
2201 curop = LINKLIST(o);
b7f7fd0b 2202 old_next = o->op_next;
79072805 2203 o->op_next = 0;
533c011a 2204 PL_op = curop;
b7f7fd0b
NC		 2205
2206 oldscope = PL_scopestack_ix;
edb2152a 2207 create_eval_scope(G_FAKINGEVAL);
b7f7fd0b 2208
b7f7fd0b
NC		 2209 JMPENV_PUSH(ret);
2210
2211 switch (ret) {
2212 case 0:
2213 CALLRUNOPS(aTHX);
2214 sv = *(PL_stack_sp--);
2215 if (o->op_targ && sv == PAD_SV(o->op_targ)) /* grab pad temp? */
2216 pad_swipe(o->op_targ, FALSE);
2217 else if (SvTEMP(sv)) { /* grab mortal temp? */
2218 SvREFCNT_inc_simple_void(sv);
2219 SvTEMP_off(sv);
2220 }
2221 break;
2222 case 3:
2223 /* Something tried to die. Abandon constant folding. */
2224 /* Pretend the error never happened. */
2225 sv_setpvn(ERRSV,"",0);
2226 o->op_next = old_next;
2227 break;
2228 default:
2229 JMPENV_POP;
2230 /* Don't expect 1 (setjmp failed) or 2 (something called my_exit) */
2231 Perl_croak(aTHX_ "panic: fold_constants JMPENV_PUSH returned %d", ret);
2232 }
2233
2234 JMPENV_POP;
edb2152a
NC		 2235
2236 if (PL_scopestack_ix > oldscope)
2237 delete_eval_scope();
eb8433b7 2238
b7f7fd0b
NC		 2239 if (ret)
2240 goto nope;
2241
eb8433b7 2242#ifndef PERL_MAD
79072805 2243 op_free(o);
eb8433b7 2244#endif
79072805 2245 if (type == OP_RV2GV)
eb8433b7
NC		 2246 newop = newGVOP(OP_GV, 0, (GV*)sv);
2247 else
2248 newop = newSVOP(OP_CONST, 0, sv);
2249 op_getmad(o,newop,'f');
2250 return newop;
aeea060c 2251
b7f7fd0b 2252 nope:
79072805
LW		 2253 return o;
2254}
2255
2256OP *
864dbfa3 2257Perl_gen_constant_list(pTHX_ register OP *o)
79072805 2258{
27da23d5 2259 dVAR;
79072805 2260 register OP *curop;
6867be6d 2261 const I32 oldtmps_floor = PL_tmps_floor;
79072805 2262
a0d0e21e 2263 list(o);
3280af22 2264 if (PL_error_count)
a0d0e21e
LW		 2265 return o; /* Don't attempt to run with errors */
2266
533c011a 2267 PL_op = curop = LINKLIST(o);
a0d0e21e 2268 o->op_next = 0;
a2efc822 2269 CALL_PEEP(curop);
cea2e8a9
GS		 2270 pp_pushmark();
2271 CALLRUNOPS(aTHX);
533c011a 2272 PL_op = curop;
cea2e8a9 2273 pp_anonlist();
3280af22 2274 PL_tmps_floor = oldtmps_floor;
79072805
LW		 2275
2276 o->op_type = OP_RV2AV;
22c35a8c 2277 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
fb53bbb2
SG		 2278 o->op_flags &= ~OPf_REF; /* treat \(1..2) like an ordinary list */
2279 o->op_flags |= OPf_PARENS; /* and flatten \(1..2,3) */
2814eb74 2280 o->op_opt = 0; /* needs to be revisited in peep() */
79072805 2281 curop = ((UNOP*)o)->op_first;
b37c2d43 2282 ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, SvREFCNT_inc_NN(*PL_stack_sp--));
eb8433b7
NC		 2283#ifdef PERL_MAD
2284 op_getmad(curop,o,'O');
2285#else
79072805 2286 op_free(curop);
eb8433b7 2287#endif
79072805
LW		 2288 linklist(o);
2289 return list(o);
2290}
2291
2292OP *
864dbfa3 2293Perl_convert(pTHX_ I32 type, I32 flags, OP *o)
79072805 2294{
27da23d5 2295 dVAR;
11343788 2296 if (!o || o->op_type != OP_LIST)
5f66b61c 2297 o = newLISTOP(OP_LIST, 0, o, NULL);
748a9306 2298 else
5dc0d613 2299 o->op_flags &= ~OPf_WANT;
79072805 2300
22c35a8c 2301 if (!(PL_opargs[type] & OA_MARK))
93c66552 2302 op_null(cLISTOPo->op_first);
8990e307 2303
eb160463 2304 o->op_type = (OPCODE)type;
22c35a8c 2305 o->op_ppaddr = PL_ppaddr[type];
11343788 2306 o->op_flags |= flags;
79072805 2307
11343788 2308 o = CHECKOP(type, o);
fe2774ed 2309 if (o->op_type != (unsigned)type)
11343788 2310 return o;
79072805 2311
11343788 2312 return fold_constants(o);
79072805
LW		 2313}
2314
2315/* List constructors */
2316
2317OP *
864dbfa3 2318Perl_append_elem(pTHX_ I32 type, OP *first, OP *last)
79072805
LW		 2319{
2320 if (!first)
2321 return last;
8990e307
LW		 2322
2323 if (!last)
79072805 2324 return first;
8990e307 2325
fe2774ed 2326 if (first->op_type != (unsigned)type
155aba94
GS		 2327 || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
2328 {
2329 return newLISTOP(type, 0, first, last);
2330 }
79072805 2331
a0d0e21e
LW		 2332 if (first->op_flags & OPf_KIDS)
2333 ((LISTOP*)first)->op_last->op_sibling = last;
2334 else {
2335 first->op_flags |= OPf_KIDS;
2336 ((LISTOP*)first)->op_first = last;
2337 }
2338 ((LISTOP*)first)->op_last = last;
a0d0e21e 2339 return first;
79072805
LW		 2340}
2341
2342OP *
864dbfa3 2343Perl_append_list(pTHX_ I32 type, LISTOP *first, LISTOP *last)
79072805
LW		 2344{
2345 if (!first)
2346 return (OP*)last;
8990e307
LW		 2347
2348 if (!last)
79072805 2349 return (OP*)first;
8990e307 2350
fe2774ed 2351 if (first->op_type != (unsigned)type)
79072805 2352 return prepend_elem(type, (OP*)first, (OP*)last);
8990e307 2353
fe2774ed 2354 if (last->op_type != (unsigned)type)
79072805
LW		 2355 return append_elem(type, (OP*)first, (OP*)last);
2356
2357 first->op_last->op_sibling = last->op_first;
2358 first->op_last = last->op_last;
117dada2 2359 first->op_flags |= (last->op_flags & OPf_KIDS);
1c846c1f 2360
eb8433b7
NC		 2361#ifdef PERL_MAD
2362 if (last->op_first && first->op_madprop) {
2363 MADPROP *mp = last->op_first->op_madprop;
2364 if (mp) {
2365 while (mp->mad_next)
2366 mp = mp->mad_next;
2367 mp->mad_next = first->op_madprop;
2368 }
2369 else {
2370 last->op_first->op_madprop = first->op_madprop;
2371 }
2372 }
2373 first->op_madprop = last->op_madprop;
2374 last->op_madprop = 0;
2375#endif
2376
238a4c30
NIS		 2377 FreeOp(last);
2378
79072805
LW		 2379 return (OP*)first;
2380}
2381
2382OP *
864dbfa3 2383Perl_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
79072805
LW		 2384{
2385 if (!first)
2386 return last;
8990e307
LW		 2387
2388 if (!last)
79072805 2389 return first;
8990e307 2390
fe2774ed 2391 if (last->op_type == (unsigned)type) {
8990e307
LW		 2392 if (type == OP_LIST) { /* already a PUSHMARK there */
2393 first->op_sibling = ((LISTOP*)last)->op_first->op_sibling;
2394 ((LISTOP*)last)->op_first->op_sibling = first;
36a5d4ba
DC		 2395 if (!(first->op_flags & OPf_PARENS))
2396 last->op_flags &= ~OPf_PARENS;
8990e307
LW		 2397 }
2398 else {
2399 if (!(last->op_flags & OPf_KIDS)) {
2400 ((LISTOP*)last)->op_last = first;
2401 last->op_flags |= OPf_KIDS;
2402 }
2403 first->op_sibling = ((LISTOP*)last)->op_first;
2404 ((LISTOP*)last)->op_first = first;
79072805 2405 }
117dada2 2406 last->op_flags |= OPf_KIDS;
79072805
LW		 2407 return last;
2408 }
2409
2410 return newLISTOP(type, 0, first, last);
2411}
2412
2413/* Constructors */
2414
eb8433b7
NC		 2415#ifdef PERL_MAD
2416
2417TOKEN *
2418Perl_newTOKEN(pTHX_ I32 optype, YYSTYPE lval, MADPROP* madprop)
2419{
2420 TOKEN *tk;
99129197 2421 Newxz(tk, 1, TOKEN);
eb8433b7
NC		 2422 tk->tk_type = (OPCODE)optype;
2423 tk->tk_type = 12345;
2424 tk->tk_lval = lval;
2425 tk->tk_mad = madprop;
2426 return tk;
2427}
2428
2429void
2430Perl_token_free(pTHX_ TOKEN* tk)
2431{
2432 if (tk->tk_type != 12345)
2433 return;
2434 mad_free(tk->tk_mad);
2435 Safefree(tk);
2436}
2437
2438void
2439Perl_token_getmad(pTHX_ TOKEN* tk, OP* o, char slot)
2440{
2441 MADPROP* mp;
2442 MADPROP* tm;
2443 if (tk->tk_type != 12345) {
2444 Perl_warner(aTHX_ packWARN(WARN_MISC),
2445 "Invalid TOKEN object ignored");
2446 return;
2447 }
2448 tm = tk->tk_mad;
2449 if (!tm)
2450 return;
2451
2452 /* faked up qw list? */
2453 if (slot == '(' &&
2454 tm->mad_type == MAD_SV &&
2455 SvPVX((SV*)tm->mad_val)[0] == 'q')
2456 slot = 'x';
2457
2458 if (o) {
2459 mp = o->op_madprop;
2460 if (mp) {
2461 for (;;) {
2462 /* pretend constant fold didn't happen? */
2463 if (mp->mad_key == 'f' &&
2464 (o->op_type == OP_CONST ||
2465 o->op_type == OP_GV) )
2466 {
2467 token_getmad(tk,(OP*)mp->mad_val,slot);
2468 return;
2469 }
2470 if (!mp->mad_next)
2471 break;
2472 mp = mp->mad_next;
2473 }
2474 mp->mad_next = tm;
2475 mp = mp->mad_next;
2476 }
2477 else {
2478 o->op_madprop = tm;
2479 mp = o->op_madprop;
2480 }
2481 if (mp->mad_key == 'X')
2482 mp->mad_key = slot; /* just change the first one */
2483
2484 tk->tk_mad = 0;
2485 }
2486 else
2487 mad_free(tm);
2488 Safefree(tk);
2489}
2490
2491void
2492Perl_op_getmad_weak(pTHX_ OP* from, OP* o, char slot)
2493{
2494 MADPROP* mp;
2495 if (!from)
2496 return;
2497 if (o) {
2498 mp = o->op_madprop;
2499 if (mp) {
2500 for (;;) {
2501 /* pretend constant fold didn't happen? */
2502 if (mp->mad_key == 'f' &&
2503 (o->op_type == OP_CONST ||
2504 o->op_type == OP_GV) )
2505 {
2506 op_getmad(from,(OP*)mp->mad_val,slot);
2507 return;
2508 }
2509 if (!mp->mad_next)
2510 break;
2511 mp = mp->mad_next;
2512 }
2513 mp->mad_next = newMADPROP(slot,MAD_OP,from,0);
2514 }
2515 else {
2516 o->op_madprop = newMADPROP(slot,MAD_OP,from,0);
2517 }
2518 }
2519}
2520
2521void
2522Perl_op_getmad(pTHX_ OP* from, OP* o, char slot)
2523{
2524 MADPROP* mp;
2525 if (!from)
2526 return;
2527 if (o) {
2528 mp = o->op_madprop;
2529 if (mp) {
2530 for (;;) {
2531 /* pretend constant fold didn't happen? */
2532 if (mp->mad_key == 'f' &&
2533 (o->op_type == OP_CONST ||
2534 o->op_type == OP_GV) )
2535 {
2536 op_getmad(from,(OP*)mp->mad_val,slot);
2537 return;
2538 }
2539 if (!mp->mad_next)
2540 break;
2541 mp = mp->mad_next;
2542 }
2543 mp->mad_next = newMADPROP(slot,MAD_OP,from,1);
2544 }
2545 else {
2546 o->op_madprop = newMADPROP(slot,MAD_OP,from,1);
2547 }
2548 }
2549 else {
99129197
NC		 2550 PerlIO_printf(PerlIO_stderr(),
2551 "DESTROYING op = %0"UVxf"\n", PTR2UV(from));
eb8433b7
NC		 2552 op_free(from);
2553 }
2554}
2555
2556void
2557Perl_prepend_madprops(pTHX_ MADPROP* mp, OP* o, char slot)
2558{
2559 MADPROP* tm;
2560 if (!mp || !o)
2561 return;
2562 if (slot)
2563 mp->mad_key = slot;
2564 tm = o->op_madprop;
2565 o->op_madprop = mp;
2566 for (;;) {
2567 if (!mp->mad_next)
2568 break;
2569 mp = mp->mad_next;
2570 }
2571 mp->mad_next = tm;
2572}
2573
2574void
2575Perl_append_madprops(pTHX_ MADPROP* tm, OP* o, char slot)
2576{
2577 if (!o)
2578 return;
2579 addmad(tm, &(o->op_madprop), slot);
2580}
2581
2582void
2583Perl_addmad(pTHX_ MADPROP* tm, MADPROP** root, char slot)
2584{
2585 MADPROP* mp;
2586 if (!tm || !root)
2587 return;
2588 if (slot)
2589 tm->mad_key = slot;
2590 mp = *root;
2591 if (!mp) {
2592 *root = tm;
2593 return;
2594 }
2595 for (;;) {
2596 if (!mp->mad_next)
2597 break;
2598 mp = mp->mad_next;
2599 }
2600 mp->mad_next = tm;
2601}
2602
2603MADPROP *
2604Perl_newMADsv(pTHX_ char key, SV* sv)
2605{
2606 return newMADPROP(key, MAD_SV, sv, 0);
2607}
2608
2609MADPROP *
2610Perl_newMADPROP(pTHX_ char key, char type, void* val, I32 vlen)
2611{
2612 MADPROP *mp;
99129197 2613 Newxz(mp, 1, MADPROP);
eb8433b7
NC		 2614 mp->mad_next = 0;
2615 mp->mad_key = key;
2616 mp->mad_vlen = vlen;
2617 mp->mad_type = type;
2618 mp->mad_val = val;
2619/* PerlIO_printf(PerlIO_stderr(), "NEW mp = %0x\n", mp); */
2620 return mp;
2621}
2622
2623void
2624Perl_mad_free(pTHX_ MADPROP* mp)
2625{
2626/* PerlIO_printf(PerlIO_stderr(), "FREE mp = %0x\n", mp); */
2627 if (!mp)
2628 return;
2629 if (mp->mad_next)
2630 mad_free(mp->mad_next);
2631/* if (PL_lex_state != LEX_NOTPARSING && mp->mad_vlen)
2632 PerlIO_printf(PerlIO_stderr(), "DESTROYING '%c'=<%s>\n", mp->mad_key & 255, mp->mad_val); */
2633 switch (mp->mad_type) {
2634 case MAD_NULL:
2635 break;
2636 case MAD_PV:
2637 Safefree((char*)mp->mad_val);
2638 break;
2639 case MAD_OP:
2640 if (mp->mad_vlen) /* vlen holds "strong/weak" boolean */
2641 op_free((OP*)mp->mad_val);
2642 break;
2643 case MAD_SV:
2644 sv_free((SV*)mp->mad_val);
2645 break;
2646 default:
2647 PerlIO_printf(PerlIO_stderr(), "Unrecognized mad\n");
2648 break;
2649 }
2650 Safefree(mp);
2651}
2652
2653#endif
2654
79072805 2655OP *
864dbfa3 2656Perl_newNULLLIST(pTHX)
79072805 2657{
8990e307
LW		 2658 return newOP(OP_STUB, 0);
2659}
2660
2661OP *
864dbfa3 2662Perl_force_list(pTHX_ OP *o)
8990e307 2663{
11343788 2664 if (!o || o->op_type != OP_LIST)
5f66b61c 2665 o = newLISTOP(OP_LIST, 0, o, NULL);
93c66552 2666 op_null(o);
11343788 2667 return o;
79072805
LW		 2668}
2669
2670OP *
864dbfa3 2671Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
79072805 2672{
27da23d5 2673 dVAR;
79072805
LW		 2674 LISTOP *listop;
2675
b7dc083c 2676 NewOp(1101, listop, 1, LISTOP);
79072805 2677
eb160463 2678 listop->op_type = (OPCODE)type;
22c35a8c 2679 listop->op_ppaddr = PL_ppaddr[type];
117dada2
SM		 2680 if (first || last)
2681 flags |= OPf_KIDS;
eb160463 2682 listop->op_flags = (U8)flags;
79072805
LW		 2683
2684 if (!last && first)
2685 last = first;
2686 else if (!first && last)
2687 first = last;
8990e307
LW		 2688 else if (first)
2689 first->op_sibling = last;
79072805
LW		 2690 listop->op_first = first;
2691 listop->op_last = last;
8990e307 2692 if (type == OP_LIST) {
551405c4 2693 OP* const pushop = newOP(OP_PUSHMARK, 0);
8990e307
LW		 2694 pushop->op_sibling = first;
2695 listop->op_first = pushop;
2696 listop->op_flags |= OPf_KIDS;
2697 if (!last)
2698 listop->op_last = pushop;
2699 }
79072805 2700
463d09e6 2701 return CHECKOP(type, listop);
79072805
LW		 2702}
2703
2704OP *
864dbfa3 2705Perl_newOP(pTHX_ I32 type, I32 flags)
79072805 2706{
27da23d5 2707 dVAR;
11343788 2708 OP *o;
b7dc083c 2709 NewOp(1101, o, 1, OP);
eb160463 2710 o->op_type = (OPCODE)type;
22c35a8c 2711 o->op_ppaddr = PL_ppaddr[type];
eb160463 2712 o->op_flags = (U8)flags;
79072805 2713
11343788 2714 o->op_next = o;
eb160463 2715 o->op_private = (U8)(0 | (flags >> 8));
22c35a8c 2716 if (PL_opargs[type] & OA_RETSCALAR)
11343788 2717 scalar(o);
22c35a8c 2718 if (PL_opargs[type] & OA_TARGET)
11343788
MB		 2719 o->op_targ = pad_alloc(type, SVs_PADTMP);
2720 return CHECKOP(type, o);
79072805
LW		 2721}
2722
2723OP *
864dbfa3 2724Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
79072805 2725{
27da23d5 2726 dVAR;
79072805
LW		 2727 UNOP *unop;
2728
93a17b20 2729 if (!first)
aeea060c 2730 first = newOP(OP_STUB, 0);
22c35a8c 2731 if (PL_opargs[type] & OA_MARK)
8990e307 2732 first = force_list(first);
93a17b20 2733
b7dc083c 2734 NewOp(1101, unop, 1, UNOP);
eb160463 2735 unop->op_type = (OPCODE)type;
22c35a8c 2736 unop->op_ppaddr = PL_ppaddr[type];
79072805 2737 unop->op_first = first;
585ec06d 2738 unop->op_flags = (U8)(flags | OPf_KIDS);
eb160463 2739 unop->op_private = (U8)(1 | (flags >> 8));
e50aee73 2740 unop = (UNOP*) CHECKOP(type, unop);
79072805
LW		 2741 if (unop->op_next)
2742 return (OP*)unop;
2743
a0d0e21e 2744 return fold_constants((OP *) unop);
79072805
LW		 2745}
2746
2747OP *
864dbfa3 2748Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
79072805 2749{
27da23d5 2750 dVAR;
79072805 2751 BINOP *binop;
b7dc083c 2752 NewOp(1101, binop, 1, BINOP);
79072805
LW		 2753
2754 if (!first)
2755 first = newOP(OP_NULL, 0);
2756
eb160463 2757 binop->op_type = (OPCODE)type;
22c35a8c 2758 binop->op_ppaddr = PL_ppaddr[type];
79072805 2759 binop->op_first = first;
585ec06d 2760 binop->op_flags = (U8)(flags | OPf_KIDS);
79072805
LW		 2761 if (!last) {
2762 last = first;
eb160463 2763 binop->op_private = (U8)(1 | (flags >> 8));
79072805
LW		 2764 }
2765 else {
eb160463 2766 binop->op_private = (U8)(2 | (flags >> 8));
79072805
LW		 2767 first->op_sibling = last;
2768 }
2769
e50aee73 2770 binop = (BINOP*)CHECKOP(type, binop);
eb160463 2771 if (binop->op_next || binop->op_type != (OPCODE)type)
79072805
LW		 2772 return (OP*)binop;
2773
7284ab6f 2774 binop->op_last = binop->op_first->op_sibling;
79072805 2775
a0d0e21e 2776 return fold_constants((OP *)binop);
79072805
LW		 2777}
2778
5f66b61c
AL		 2779static int uvcompare(const void *a, const void *b)
2780 __attribute__nonnull__(1)
2781 __attribute__nonnull__(2)
2782 __attribute__pure__;
abb2c242 2783static int uvcompare(const void *a, const void *b)
2b9d42f0 2784{
e1ec3a88 2785 if (*((const UV *)a) < (*(const UV *)b))
2b9d42f0 2786 return -1;
e1ec3a88 2787 if (*((const UV *)a) > (*(const UV *)b))
2b9d42f0 2788 return 1;
e1ec3a88 2789 if (*((const UV *)a+1) < (*(const UV *)b+1))
2b9d42f0 2790 return -1;
e1ec3a88 2791 if (*((const UV *)a+1) > (*(const UV *)b+1))
2b9d42f0 2792 return 1;
a0ed51b3
LW		 2793 return 0;
2794}
2795
79072805 2796OP *
864dbfa3 2797Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
79072805 2798{
97aff369 2799 dVAR;
2d03de9c
AL		 2800 SV * const tstr = ((SVOP*)expr)->op_sv;
2801 SV * const rstr = ((SVOP*)repl)->op_sv;
463ee0b2
LW		 2802 STRLEN tlen;
2803 STRLEN rlen;
5c144d81
NC		 2804 const U8 *t = (U8*)SvPV_const(tstr, tlen);
2805 const U8 *r = (U8*)SvPV_const(rstr, rlen);
79072805
LW		 2806 register I32 i;
2807 register I32 j;
9b877dbb 2808 I32 grows = 0;
79072805
LW		 2809 register short *tbl;
2810
551405c4
AL		 2811 const I32 complement = o->op_private & OPpTRANS_COMPLEMENT;
2812 const I32 squash = o->op_private & OPpTRANS_SQUASH;
2813 I32 del = o->op_private & OPpTRANS_DELETE;
800b4dc4 2814 PL_hints |= HINT_BLOCK_SCOPE;
1c846c1f 2815
036b4402
GS		 2816 if (SvUTF8(tstr))
2817 o->op_private |= OPpTRANS_FROM_UTF;
1c846c1f
NIS		 2818
2819 if (SvUTF8(rstr))
036b4402 2820 o->op_private |= OPpTRANS_TO_UTF;
79072805 2821
a0ed51b3 2822 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
396482e1 2823 SV* const listsv = newSVpvs("# comment\n");
c445ea15 2824 SV* transv = NULL;
5c144d81
NC		 2825 const U8* tend = t + tlen;
2826 const U8* rend = r + rlen;
ba210ebe 2827 STRLEN ulen;
84c133a0
RB		 2828 UV tfirst = 1;
2829 UV tlast = 0;
2830 IV tdiff;
2831 UV rfirst = 1;
2832 UV rlast = 0;
2833 IV rdiff;
2834 IV diff;
a0ed51b3
LW		 2835 I32 none = 0;
2836 U32 max = 0;
2837 I32 bits;
a0ed51b3 2838 I32 havefinal = 0;
9c5ffd7c 2839 U32 final = 0;
551405c4
AL		 2840 const I32 from_utf = o->op_private & OPpTRANS_FROM_UTF;
2841 const I32 to_utf = o->op_private & OPpTRANS_TO_UTF;
bf4a1e57
JH		 2842 U8* tsave = NULL;
2843 U8* rsave = NULL;
2844
2845 if (!from_utf) {
2846 STRLEN len = tlen;
5c144d81 2847 t = tsave = bytes_to_utf8(t, &len);
bf4a1e57
JH		 2848 tend = t + len;
2849 }
2850 if (!to_utf && rlen) {
2851 STRLEN len = rlen;
5c144d81 2852 r = rsave = bytes_to_utf8(r, &len);
bf4a1e57
JH		 2853 rend = r + len;
2854 }
a0ed51b3 2855
2b9d42f0
NIS		 2856/* There are several snags with this code on EBCDIC:
2857 1. 0xFF is a legal UTF-EBCDIC byte (there are no illegal bytes).
2858 2. scan_const() in toke.c has encoded chars in native encoding which makes
2859 ranges at least in EBCDIC 0..255 range the bottom odd.
2860*/
2861
a0ed51b3 2862 if (complement) {
89ebb4a3 2863 U8 tmpbuf[UTF8_MAXBYTES+1];
2b9d42f0 2864 UV *cp;
a0ed51b3 2865 UV nextmin = 0;
a02a5408 2866 Newx(cp, 2*tlen, UV);
a0ed51b3 2867 i = 0;
396482e1 2868 transv = newSVpvs("");
a0ed51b3 2869 while (t < tend) {
2b9d42f0
NIS		 2870 cp[2*i] = utf8n_to_uvuni(t, tend-t, &ulen, 0);
2871 t += ulen;
2872 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) {
a0ed51b3 2873 t++;
2b9d42f0
NIS		 2874 cp[2*i+1] = utf8n_to_uvuni(t, tend-t, &ulen, 0);
2875 t += ulen;
a0ed51b3 2876 }
2b9d42f0
NIS		 2877 else {
2878 cp[2*i+1] = cp[2*i];
2879 }
2880 i++;
a0ed51b3 2881 }
2b9d42f0 2882 qsort(cp, i, 2*sizeof(UV), uvcompare);
a0ed51b3 2883 for (j = 0; j < i; j++) {
2b9d42f0 2884 UV val = cp[2*j];
a0ed51b3
LW		 2885 diff = val - nextmin;
2886 if (diff > 0) {
9041c2e3 2887 t = uvuni_to_utf8(tmpbuf,nextmin);
dfe13c55 2888 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
a0ed51b3 2889 if (diff > 1) {
2b9d42f0 2890 U8 range_mark = UTF_TO_NATIVE(0xff);
9041c2e3 2891 t = uvuni_to_utf8(tmpbuf, val - 1);
2b9d42f0 2892 sv_catpvn(transv, (char *)&range_mark, 1);
dfe13c55 2893 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
a0ed51b3
LW		 2894 }
2895 }
2b9d42f0 2896 val = cp[2*j+1];
a0ed51b3
LW		 2897 if (val >= nextmin)
2898 nextmin = val + 1;
2899 }
9041c2e3 2900 t = uvuni_to_utf8(tmpbuf,nextmin);
dfe13c55 2901 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2b9d42f0
NIS		 2902 {
2903 U8 range_mark = UTF_TO_NATIVE(0xff);
2904 sv_catpvn(transv, (char *)&range_mark, 1);
2905 }
b851fbc1
JH		 2906 t = uvuni_to_utf8_flags(tmpbuf, 0x7fffffff,
2907 UNICODE_ALLOW_SUPER);
dfe13c55 2908 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
93524f2b 2909 t = (const U8*)SvPVX_const(transv);
a0ed51b3
LW		 2910 tlen = SvCUR(transv);
2911 tend = t + tlen;
455d824a 2912 Safefree(cp);
a0ed51b3
LW		 2913 }
2914 else if (!rlen && !del) {
2915 r = t; rlen = tlen; rend = tend;
4757a243
LW		 2916 }
2917 if (!squash) {
05d340b8 2918 if ((!rlen && !del) || t == r ||
12ae5dfc 2919 (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
01ec43d0 2920 {
4757a243 2921 o->op_private |= OPpTRANS_IDENTICAL;
01ec43d0 2922 }
a0ed51b3
LW		 2923 }
2924
2925 while (t < tend || tfirst <= tlast) {
2926 /* see if we need more "t" chars */
2927 if (tfirst > tlast) {
9041c2e3 2928 tfirst = (I32)utf8n_to_uvuni(t, tend - t, &ulen, 0);
a0ed51b3 2929 t += ulen;
2b9d42f0 2930 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) { /* illegal utf8 val indicates range */
ba210ebe 2931 t++;
9041c2e3 2932 tlast = (I32)utf8n_to_uvuni(t, tend - t, &ulen, 0);
a0ed51b3
LW		 2933 t += ulen;
2934 }
2935 else
2936 tlast = tfirst;
2937 }
2938
2939 /* now see if we need more "r" chars */
2940 if (rfirst > rlast) {
2941 if (r < rend) {
9041c2e3 2942 rfirst = (I32)utf8n_to_uvuni(r, rend - r, &ulen, 0);
a0ed51b3 2943 r += ulen;
2b9d42f0 2944 if (r < rend && NATIVE_TO_UTF(*r) == 0xff) { /* illegal utf8 val indicates range */
ba210ebe 2945 r++;
9041c2e3 2946 rlast = (I32)utf8n_to_uvuni(r, rend - r, &ulen, 0);
a0ed51b3
LW		 2947 r += ulen;
2948 }
2949 else
2950 rlast = rfirst;
2951 }
2952 else {
2953 if (!havefinal++)
2954 final = rlast;
2955 rfirst = rlast = 0xffffffff;
2956 }
2957 }
2958
2959 /* now see which range will peter our first, if either. */
2960 tdiff = tlast - tfirst;
2961 rdiff = rlast - rfirst;
2962
2963 if (tdiff <= rdiff)
2964 diff = tdiff;
2965 else
2966 diff = rdiff;
2967
2968 if (rfirst == 0xffffffff) {
2969 diff = tdiff; /* oops, pretend rdiff is infinite */
2970 if (diff > 0)
894356b3
GS		 2971 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
2972 (long)tfirst, (long)tlast);
a0ed51b3 2973 else
894356b3 2974 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
a0ed51b3
LW		 2975 }
2976 else {
2977 if (diff > 0)
894356b3
GS		 2978 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
2979 (long)tfirst, (long)(tfirst + diff),
2980 (long)rfirst);
a0ed51b3 2981 else
894356b3
GS		 2982 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
2983 (long)tfirst, (long)rfirst);
a0ed51b3
LW		 2984
2985 if (rfirst + diff > max)
2986 max = rfirst + diff;
9b877dbb 2987 if (!grows)
45005bfb
JH		 2988 grows = (tfirst < rfirst &&
2989 UNISKIP(tfirst) < UNISKIP(rfirst + diff));
2990 rfirst += diff + 1;
a0ed51b3
LW		 2991 }
2992 tfirst += diff + 1;
2993 }
2994
2995 none = ++max;
2996 if (del)
2997 del = ++max;
2998
2999 if (max > 0xffff)
3000 bits = 32;
3001 else if (max > 0xff)
3002 bits = 16;
3003 else
3004 bits = 8;
3005
455d824a 3006 Safefree(cPVOPo->op_pv);
a0ed51b3
LW		 3007 cSVOPo->op_sv = (SV*)swash_init("utf8", "", listsv, bits, none);
3008 SvREFCNT_dec(listsv);
b37c2d43 3009 SvREFCNT_dec(transv);
a0ed51b3 3010
45005bfb 3011 if (!del && havefinal && rlen)
b448e4fe
JH		 3012 (void)hv_store((HV*)SvRV((cSVOPo->op_sv)), "FINAL", 5,
3013 newSVuv((UV)final), 0);
a0ed51b3 3014
9b877dbb 3015 if (grows)
a0ed51b3
LW		 3016 o->op_private |= OPpTRANS_GROWS;
3017
b37c2d43
AL		 3018 Safefree(tsave);
3019 Safefree(rsave);
9b877dbb 3020
eb8433b7
NC		 3021#ifdef PERL_MAD
3022 op_getmad(expr,o,'e');
3023 op_getmad(repl,o,'r');
3024#else
a0ed51b3
LW		 3025 op_free(expr);
3026 op_free(repl);
eb8433b7 3027#endif
a0ed51b3
LW		 3028 return o;
3029 }
3030
3031 tbl = (short*)cPVOPo->op_pv;
79072805
LW		 3032 if (complement) {
3033 Zero(tbl, 256, short);
eb160463 3034 for (i = 0; i < (I32)tlen; i++)
ec49126f 3035 tbl[t[i]] = -1;
79072805
LW		 3036 for (i = 0, j = 0; i < 256; i++) {
3037 if (!tbl[i]) {
eb160463 3038 if (j >= (I32)rlen) {
a0ed51b3 3039 if (del)
79072805
LW		 3040 tbl[i] = -2;
3041 else if (rlen)
ec49126f 3042 tbl[i] = r[j-1];
79072805 3043 else
eb160463 3044 tbl[i] = (short)i;
79072805 3045 }
9b877dbb
IH		 3046 else {
3047 if (i < 128 && r[j] >= 128)
3048 grows = 1;
ec49126f 3049 tbl[i] = r[j++];
9b877dbb 3050 }
79072805
LW		 3051 }
3052 }
05d340b8
JH		 3053 if (!del) {
3054 if (!rlen) {
3055 j = rlen;
3056 if (!squash)
3057 o->op_private |= OPpTRANS_IDENTICAL;
3058 }
eb160463 3059 else if (j >= (I32)rlen)
05d340b8
JH		 3060 j = rlen - 1;
3061 else
3062 cPVOPo->op_pv = (char*)Renew(tbl, 0x101+rlen-j, short);
585ec06d 3063 tbl[0x100] = (short)(rlen - j);
eb160463 3064 for (i=0; i < (I32)rlen - j; i++)
8973db79
JH		 3065 tbl[0x101+i] = r[j+i];
3066 }
79072805
LW		 3067 }
3068 else {
a0ed51b3 3069 if (!rlen && !del) {
79072805 3070 r = t; rlen = tlen;
5d06d08e 3071 if (!squash)
4757a243 3072 o->op_private |= OPpTRANS_IDENTICAL;
79072805 3073 }
94bfe852
RGS		 3074 else if (!squash && rlen == tlen && memEQ((char*)t, (char*)r, tlen)) {
3075 o->op_private |= OPpTRANS_IDENTICAL;
3076 }
79072805
LW		 3077 for (i = 0; i < 256; i++)
3078 tbl[i] = -1;
eb160463
GS		 3079 for (i = 0, j = 0; i < (I32)tlen; i++,j++) {
3080 if (j >= (I32)rlen) {
a0ed51b3 3081 if (del) {
ec49126f 3082 if (tbl[t[i]] == -1)
3083 tbl[t[i]] = -2;
79072805
LW		 3084 continue;
3085 }
3086 --j;
3087 }
9b877dbb
IH		 3088 if (tbl[t[i]] == -1) {
3089 if (t[i] < 128 && r[j] >= 128)
3090 grows = 1;
ec49126f 3091 tbl[t[i]] = r[j];
9b877dbb 3092 }
79072805
LW		 3093 }
3094 }
9b877dbb
IH		 3095 if (grows)
3096 o->op_private |= OPpTRANS_GROWS;
eb8433b7
NC		 3097#ifdef PERL_MAD
3098 op_getmad(expr,o,'e');
3099 op_getmad(repl,o,'r');
3100#else
79072805
LW		 3101 op_free(expr);
3102 op_free(repl);
eb8433b7 3103#endif
79072805 3104
11343788 3105 return o;
79072805
LW		 3106}
3107
3108OP *
864dbfa3 3109Perl_newPMOP(pTHX_ I32 type, I32 flags)
79072805 3110{
27da23d5 3111 dVAR;
79072805
LW		 3112 PMOP *pmop;
3113
b7dc083c 3114 NewOp(1101, pmop, 1, PMOP);
eb160463 3115 pmop->op_type = (OPCODE)type;
22c35a8c 3116 pmop->op_ppaddr = PL_ppaddr[type];
eb160463
GS		 3117 pmop->op_flags = (U8)flags;
3118 pmop->op_private = (U8)(0 | (flags >> 8));
79072805 3119
3280af22 3120 if (PL_hints & HINT_RE_TAINT)
b3eb6a9b 3121 pmop->op_pmpermflags |= PMf_RETAINT;
3280af22 3122 if (PL_hints & HINT_LOCALE)
b3eb6a9b
GS		 3123 pmop->op_pmpermflags |= PMf_LOCALE;
3124 pmop->op_pmflags = pmop->op_pmpermflags;
36477c24 3125
debc9467 3126#ifdef USE_ITHREADS
551405c4
AL		 3127 if (av_len((AV*) PL_regex_pad[0]) > -1) {
3128 SV * const repointer = av_pop((AV*)PL_regex_pad[0]);
3129 pmop->op_pmoffset = SvIV(repointer);
3130 SvREPADTMP_off(repointer);
3131 sv_setiv(repointer,0);
3132 } else {
3133 SV * const repointer = newSViv(0);
b37c2d43 3134 av_push(PL_regex_padav, SvREFCNT_inc_simple_NN(repointer));
551405c4
AL		 3135 pmop->op_pmoffset = av_len(PL_regex_padav);
3136 PL_regex_pad = AvARRAY(PL_regex_padav);
13137afc 3137 }
debc9467 3138#endif
1eb1540c 3139
1fcf4c12 3140 /* link into pm list */
3280af22 3141 if (type != OP_TRANS && PL_curstash) {
8d2f4536
NC		 3142 MAGIC *mg = mg_find((SV*)PL_curstash, PERL_MAGIC_symtab);
3143
3144 if (!mg) {
3145 mg = sv_magicext((SV*)PL_curstash, 0, PERL_MAGIC_symtab, 0, 0, 0);
3146 }
3147 pmop->op_pmnext = (PMOP*)mg->mg_obj;
3148 mg->mg_obj = (SV*)pmop;
cb55de95 3149 PmopSTASH_set(pmop,PL_curstash);
79072805
LW		 3150 }
3151
463d09e6 3152 return CHECKOP(type, pmop);
79072805
LW		 3153}
3154
131b3ad0
DM		 3155/* Given some sort of match op o, and an expression expr containing a
3156 * pattern, either compile expr into a regex and attach it to o (if it's
3157 * constant), or convert expr into a runtime regcomp op sequence (if it's
3158 * not)
3159 *
3160 * isreg indicates that the pattern is part of a regex construct, eg
3161 * $x =~ /pattern/ or split /pattern/, as opposed to $x =~ $pattern or
3162 * split "pattern", which aren't. In the former case, expr will be a list
3163 * if the pattern contains more than one term (eg /a$b/) or if it contains
3164 * a replacement, ie s/// or tr///.
3165 */
3166
79072805 3167OP *
131b3ad0 3168Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg)
79072805 3169{
27da23d5 3170 dVAR;
79072805
LW		 3171 PMOP *pm;
3172 LOGOP *rcop;
ce862d02 3173 I32 repl_has_vars = 0;
5f66b61c 3174 OP* repl = NULL;
131b3ad0
DM		 3175 bool reglist;
3176
3177 if (o->op_type == OP_SUBST || o->op_type == OP_TRANS) {
3178 /* last element in list is the replacement; pop it */
3179 OP* kid;
3180 repl = cLISTOPx(expr)->op_last;
3181 kid = cLISTOPx(expr)->op_first;
3182 while (kid->op_sibling != repl)
3183 kid = kid->op_sibling;
5f66b61c 3184 kid->op_sibling = NULL;
131b3ad0
DM		 3185 cLISTOPx(expr)->op_last = kid;
3186 }
79072805 3187
131b3ad0
DM		 3188 if (isreg && expr->op_type == OP_LIST &&
3189 cLISTOPx(expr)->op_first->op_sibling == cLISTOPx(expr)->op_last)
3190 {
3191 /* convert single element list to element */
0bd48802 3192 OP* const oe = expr;
131b3ad0 3193 expr = cLISTOPx(oe)->op_first->op_sibling;
5f66b61c
AL		 3194 cLISTOPx(oe)->op_first->op_sibling = NULL;
3195 cLISTOPx(oe)->op_last = NULL;
131b3ad0
DM		 3196 op_free(oe);
3197 }
3198
3199 if (o->op_type == OP_TRANS) {
11343788 3200 return pmtrans(o, expr, repl);
131b3ad0
DM		 3201 }
3202
3203 reglist = isreg && expr->op_type == OP_LIST;
3204 if (reglist)
3205 op_null(expr);
79072805 3206
3280af22 3207 PL_hints |= HINT_BLOCK_SCOPE;
11343788 3208 pm = (PMOP*)o;
79072805
LW		 3209
3210 if (expr->op_type == OP_CONST) {
463ee0b2 3211 STRLEN plen;
6136c704 3212 SV * const pat = ((SVOP*)expr)->op_sv;
5c144d81 3213 const char *p = SvPV_const(pat, plen);
770526c1 3214 if ((o->op_flags & OPf_SPECIAL) && (*p == ' ' && p[1] == '\0')) {
5c144d81
NC		 3215 U32 was_readonly = SvREADONLY(pat);
3216
3217 if (was_readonly) {
3218 if (SvFAKE(pat)) {
3219 sv_force_normal_flags(pat, 0);
3220 assert(!SvREADONLY(pat));
3221 was_readonly = 0;
3222 } else {
3223 SvREADONLY_off(pat);
3224 }
3225 }
3226
93a17b20 3227 sv_setpvn(pat, "\\s+", 3);
5c144d81
NC		 3228
3229 SvFLAGS(pat) |= was_readonly;
3230
3231 p = SvPV_const(pat, plen);
79072805
LW		 3232 pm->op_pmflags |= PMf_SKIPWHITE;
3233 }
5b71a6a7 3234 if (DO_UTF8(pat))
a5961de5 3235 pm->op_pmdynflags |= PMdf_UTF8;
5c144d81
NC		 3236 /* FIXME - can we make this function take const char * args? */
3237 PM_SETRE(pm, CALLREGCOMP(aTHX_ (char*)p, (char*)p + plen, pm));
aaa362c4 3238 if (strEQ("\\s+", PM_GETRE(pm)->precomp))
85e6fe83 3239 pm->op_pmflags |= PMf_WHITE;
eb8433b7
NC		 3240#ifdef PERL_MAD
3241 op_getmad(expr,(OP*)pm,'e');
3242#else
79072805 3243 op_free(expr);
eb8433b7 3244#endif
79072805
LW		 3245 }
3246 else {
3280af22 3247 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL))
1c846c1f 3248 expr = newUNOP((!(PL_hints & HINT_RE_EVAL)
2cd61cdb
IZ		 3249 ? OP_REGCRESET
3250 : OP_REGCMAYBE),0,expr);
463ee0b2 3251
b7dc083c 3252 NewOp(1101, rcop, 1, LOGOP);
79072805 3253 rcop->op_type = OP_REGCOMP;
22c35a8c 3254 rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP];
79072805 3255 rcop->op_first = scalar(expr);
131b3ad0
DM		 3256 rcop->op_flags |= OPf_KIDS
3257 | ((PL_hints & HINT_RE_EVAL) ? OPf_SPECIAL : 0)
3258 | (reglist ? OPf_STACKED : 0);
79072805 3259 rcop->op_private = 1;
11343788 3260 rcop->op_other = o;
131b3ad0
DM		 3261 if (reglist)
3262 rcop->op_targ = pad_alloc(rcop->op_type, SVs_PADTMP);
3263
b5c19bd7
DM		 3264 /* /$x/ may cause an eval, since $x might be qr/(?{..})/ */
3265 PL_cv_has_eval = 1;
79072805
LW		 3266
3267 /* establish postfix order */
3280af22 3268 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL)) {
463ee0b2
LW		 3269 LINKLIST(expr);
3270 rcop->op_next = expr;
3271 ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
3272 }
3273 else {
3274 rcop->op_next = LINKLIST(expr);
3275 expr->op_next = (OP*)rcop;
3276 }
79072805 3277
11343788 3278 prepend_elem(o->op_type, scalar((OP*)rcop), o);
79072805
LW		 3279 }
3280
3281 if (repl) {
748a9306 3282 OP *curop;
0244c3a4 3283 if (pm->op_pmflags & PMf_EVAL) {
6136c704 3284 curop = NULL;
8bafa735 3285 if (CopLINE(PL_curcop) < (line_t)PL_multi_end)
eb160463 3286 CopLINE_set(PL_curcop, (line_t)PL_multi_end);
0244c3a4 3287 }
748a9306
LW		 3288 else if (repl->op_type == OP_CONST)
3289 curop = repl;
79072805 3290 else {
c445ea15 3291 OP *lastop = NULL;
79072805 3292 for (curop = LINKLIST(repl); curop!=repl; curop = LINKLIST(curop)) {
22c35a8c 3293 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
79072805 3294 if (curop->op_type == OP_GV) {
6136c704 3295 GV * const gv = cGVOPx_gv(curop);
ce862d02 3296 repl_has_vars = 1;
f702bf4a 3297 if (strchr("&`'123456789+-\016\022", *GvENAME(gv)))
79072805
LW		 3298 break;
3299 }
3300 else if (curop->op_type == OP_RV2CV)
3301 break;
3302 else if (curop->op_type == OP_RV2SV ||
3303 curop->op_type == OP_RV2AV ||
3304 curop->op_type == OP_RV2HV ||
3305 curop->op_type == OP_RV2GV) {
3306 if (lastop && lastop->op_type != OP_GV) /*funny deref?*/
3307 break;
3308 }
748a9306
LW		 3309 else if (curop->op_type == OP_PADSV ||
3310 curop->op_type == OP_PADAV ||
3311 curop->op_type == OP_PADHV ||
554b3eca 3312 curop->op_type == OP_PADANY) {
ce862d02 3313 repl_has_vars = 1;
748a9306 3314 }
1167e5da 3315 else if (curop->op_type == OP_PUSHRE)
bb263b4e 3316 /*EMPTY*/; /* Okay here, dangerous in newASSIGNOP */
79072805
LW		 3317 else
3318 break;
3319 }
3320 lastop = curop;
3321 }
748a9306 3322 }
ce862d02 3323 if (curop == repl
1c846c1f 3324 && !(repl_has_vars
aaa362c4
RS		 3325 && (!PM_GETRE(pm)
3326 || PM_GETRE(pm)->reganch & ROPT_EVAL_SEEN))) {
748a9306 3327 pm->op_pmflags |= PMf_CONST; /* const for long enough */
4633a7c4 3328 pm->op_pmpermflags |= PMf_CONST; /* const for long enough */
11343788 3329 prepend_elem(o->op_type, scalar(repl), o);
748a9306
LW		 3330 }
3331 else {
aaa362c4 3332 if (curop == repl && !PM_GETRE(pm)) { /* Has variables. */
ce862d02
IZ		 3333 pm->op_pmflags |= PMf_MAYBE_CONST;
3334 pm->op_pmpermflags |= PMf_MAYBE_CONST;
3335 }
b7dc083c 3336 NewOp(1101, rcop, 1, LOGOP);
748a9306 3337 rcop->op_type = OP_SUBSTCONT;
22c35a8c 3338 rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT];
748a9306
LW		 3339 rcop->op_first = scalar(repl);
3340 rcop->op_flags |= OPf_KIDS;
3341 rcop->op_private = 1;
11343788 3342 rcop->op_other = o;
748a9306
LW		 3343
3344 /* establish postfix order */
3345 rcop->op_next = LINKLIST(repl);
3346 repl->op_next = (OP*)rcop;
3347
3348 pm->op_pmreplroot = scalar((OP*)rcop);
3349 pm->op_pmreplstart = LINKLIST(rcop);
3350 rcop->op_next = 0;
79072805
LW		 3351 }
3352 }
3353
3354 return (OP*)pm;
3355}
3356
3357OP *
864dbfa3 3358Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
79072805 3359{
27da23d5 3360 dVAR;
79072805 3361 SVOP *svop;
b7dc083c 3362 NewOp(1101, svop, 1, SVOP);
eb160463 3363 svop->op_type = (OPCODE)type;
22c35a8c 3364 svop->op_ppaddr = PL_ppaddr[type];
79072805
LW		 3365 svop->op_sv = sv;
3366 svop->op_next = (OP*)svop;
eb160463 3367 svop->op_flags = (U8)flags;
22c35a8c 3368 if (PL_opargs[type] & OA_RETSCALAR)
463ee0b2 3369 scalar((OP*)svop);
22c35a8c 3370 if (PL_opargs[type] & OA_TARGET)
ed6116ce 3371 svop->op_targ = pad_alloc(type, SVs_PADTMP);
e50aee73 3372 return CHECKOP(type, svop);
79072805
LW		 3373}
3374
3375OP *
350de78d
GS		 3376Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
3377{
27da23d5 3378 dVAR;
350de78d
GS		 3379 PADOP *padop;
3380 NewOp(1101, padop, 1, PADOP);
eb160463 3381 padop->op_type = (OPCODE)type;
350de78d
GS		 3382 padop->op_ppaddr = PL_ppaddr[type];
3383 padop->op_padix = pad_alloc(type, SVs_PADTMP);
dd2155a4
DM		 3384 SvREFCNT_dec(PAD_SVl(padop->op_padix));
3385 PAD_SETSV(padop->op_padix, sv);
ce50c033
AMS		 3386 if (sv)
3387 SvPADTMP_on(sv);
350de78d 3388 padop->op_next = (OP*)padop;
eb160463 3389 padop->op_flags = (U8)flags;
350de78d
GS		 3390 if (PL_opargs[type] & OA_RETSCALAR)
3391 scalar((OP*)padop);
3392 if (PL_opargs[type] & OA_TARGET)
3393 padop->op_targ = pad_alloc(type, SVs_PADTMP);
3394 return CHECKOP(type, padop);
3395}
3396
3397OP *
864dbfa3 3398Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
79072805 3399{
27da23d5 3400 dVAR;
350de78d 3401#ifdef USE_ITHREADS
ce50c033
AMS		 3402 if (gv)
3403 GvIN_PAD_on(gv);
b37c2d43 3404 return newPADOP(type, flags, SvREFCNT_inc_simple(gv));
350de78d 3405#else
b37c2d43 3406 return newSVOP(type, flags, SvREFCNT_inc_simple(gv));
350de78d 3407#endif
79072805
LW		 3408}
3409
3410OP *
864dbfa3 3411Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
79072805 3412{
27da23d5 3413 dVAR;
79072805 3414 PVOP *pvop;
b7dc083c 3415 NewOp(1101, pvop, 1, PVOP);
eb160463 3416 pvop->op_type = (OPCODE)type;
22c35a8c 3417 pvop->op_ppaddr = PL_ppaddr[type];
79072805
LW		 3418 pvop->op_pv = pv;
3419 pvop->op_next = (OP*)pvop;
eb160463 3420 pvop->op_flags = (U8)flags;
22c35a8c 3421 if (PL_opargs[type] & OA_RETSCALAR)
463ee0b2 3422 scalar((OP*)pvop);
22c35a8c 3423 if (PL_opargs[type] & OA_TARGET)
ed6116ce 3424 pvop->op_targ = pad_alloc(type, SVs_PADTMP);
e50aee73 3425 return CHECKOP(type, pvop);
79072805
LW		 3426}
3427
eb8433b7
NC		 3428#ifdef PERL_MAD
3429OP*
3430#else
79072805 3431void
eb8433b7 3432#endif
864dbfa3 3433Perl_package(pTHX_ OP *o)
79072805 3434{
97aff369 3435 dVAR;
6867be6d 3436 const char *name;
de11ba31 3437 STRLEN len;
eb8433b7
NC		 3438#ifdef PERL_MAD
3439 OP *pegop;
3440#endif
79072805 3441
3280af22
NIS		 3442 save_hptr(&PL_curstash);
3443 save_item(PL_curstname);
de11ba31 3444
5c144d81 3445 name = SvPV_const(cSVOPo->op_sv, len);
de11ba31
AMS		 3446 PL_curstash = gv_stashpvn(name, len, TRUE);
3447 sv_setpvn(PL_curstname, name, len);
de11ba31 3448
7ad382f4 3449 PL_hints |= HINT_BLOCK_SCOPE;
3280af22
NIS		 3450 PL_copline = NOLINE;
3451 PL_expect = XSTATE;
eb8433b7
NC		 3452
3453#ifndef PERL_MAD
3454 op_free(o);
3455#else
3456 if (!PL_madskills) {
3457 op_free(o);
1d866c12 3458 return NULL;
eb8433b7
NC		 3459 }
3460
3461 pegop = newOP(OP_NULL,0);
3462 op_getmad(o,pegop,'P');
3463 return pegop;
3464#endif
79072805
LW		 3465}
3466
eb8433b7
NC		 3467#ifdef PERL_MAD
3468OP*
3469#else
85e6fe83 3470void
eb8433b7 3471#endif
88d95a4d 3472Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg)
85e6fe83 3473{
97aff369 3474 dVAR;
a0d0e21e 3475 OP *pack;
a0d0e21e 3476 OP *imop;
b1cb66bf 3477 OP *veop;
eb8433b7
NC		 3478#ifdef PERL_MAD
3479 OP *pegop = newOP(OP_NULL,0);
3480#endif
85e6fe83 3481
88d95a4d 3482 if (idop->op_type != OP_CONST)
cea2e8a9 3483 Perl_croak(aTHX_ "Module name must be constant");
85e6fe83 3484
eb8433b7
NC		 3485 if (PL_madskills)
3486 op_getmad(idop,pegop,'U');
3487
5f66b61c 3488 veop = NULL;
b1cb66bf 3489
aec46f14 3490 if (version) {
551405c4 3491 SV * const vesv = ((SVOP*)version)->op_sv;
b1cb66bf 3492
eb8433b7
NC		 3493 if (PL_madskills)
3494 op_getmad(version,pegop,'V');
aec46f14 3495 if (!arg && !SvNIOKp(vesv)) {
b1cb66bf 3496 arg = version;
3497 }
3498 else {
3499 OP *pack;
0f79a09d 3500 SV *meth;
b1cb66bf 3501
44dcb63b 3502 if (version->op_type != OP_CONST || !SvNIOKp(vesv))
cea2e8a9 3503 Perl_croak(aTHX_ "Version number must be constant number");
b1cb66bf 3504
88d95a4d
JH		 3505 /* Make copy of idop so we don't free it twice */
3506 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
b1cb66bf 3507
3508 /* Fake up a method call to VERSION */
18916d0d 3509 meth = newSVpvs_share("VERSION");
b1cb66bf 3510 veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3511 append_elem(OP_LIST,
0f79a09d
GS		 3512 prepend_elem(OP_LIST, pack, list(version)),
3513 newSVOP(OP_METHOD_NAMED, 0, meth)));
b1cb66bf 3514 }
3515 }
aeea060c 3516
a0d0e21e 3517 /* Fake up an import/unimport */
eb8433b7
NC		 3518 if (arg && arg->op_type == OP_STUB) {
3519 if (PL_madskills)
3520 op_getmad(arg,pegop,'S');
4633a7c4 3521 imop = arg; /* no import on explicit () */
eb8433b7 3522 }
88d95a4d 3523 else if (SvNIOKp(((SVOP*)idop)->op_sv)) {
5f66b61c 3524 imop = NULL; /* use 5.0; */
468aa647
RGS		 3525 if (!aver)
3526 idop->op_private |= OPpCONST_NOVER;
b1cb66bf 3527 }
4633a7c4 3528 else {
0f79a09d
GS		 3529 SV *meth;
3530
eb8433b7
NC		 3531 if (PL_madskills)
3532 op_getmad(arg,pegop,'A');
3533
88d95a4d
JH		 3534 /* Make copy of idop so we don't free it twice */
3535 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
0f79a09d
GS		 3536
3537 /* Fake up a method call to import/unimport */
427d62a4 3538 meth = aver
18916d0d 3539 ? newSVpvs_share("import") : newSVpvs_share("unimport");
4633a7c4 3540 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
0f79a09d
GS		 3541 append_elem(OP_LIST,
3542 prepend_elem(OP_LIST, pack, list(arg)),
3543 newSVOP(OP_METHOD_NAMED, 0, meth)));
4633a7c4
LW		 3544 }
3545
a0d0e21e 3546 /* Fake up the BEGIN {}, which does its thing immediately. */
09bef843 3547 newATTRSUB(floor,
18916d0d 3548 newSVOP(OP_CONST, 0, newSVpvs_share