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
Add BmPREVIOUS_set(), and use it in the one place that BmPREVIOUS is
[perl5.git] / op.c
CommitLineData
a0d0e21e 1/* op.c
79072805 2 *
4bb101f2 3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
acde74e1 4 * 2000, 2001, 2002, 2003, 2004, 2005, 2006, by Larry Wall and others
79072805
LW		 5 *
6 * You may distribute under the terms of either the GNU General Public
7 * License or the Artistic License, as specified in the README file.
8 *
a0d0e21e
LW		 9 */
10
11/*
12 * "You see: Mr. Drogo, he married poor Miss Primula Brandybuck. She was
13 * our Mr. Bilbo's first cousin on the mother's side (her mother being the
14 * youngest of the Old Took's daughters); and Mr. Drogo was his second
15 * cousin. So Mr. Frodo is his first *and* second cousin, once removed
16 * either way, as the saying is, if you follow me." --the Gaffer
79072805
LW		 17 */
18
166f8a29
DM		 19/* This file contains the functions that create, manipulate and optimize
20 * the OP structures that hold a compiled perl program.
21 *
22 * A Perl program is compiled into a tree of OPs. Each op contains
23 * structural pointers (eg to its siblings and the next op in the
24 * execution sequence), a pointer to the function that would execute the
25 * op, plus any data specific to that op. For example, an OP_CONST op
26 * points to the pp_const() function and to an SV containing the constant
27 * value. When pp_const() is executed, its job is to push that SV onto the
28 * stack.
29 *
30 * OPs are mainly created by the newFOO() functions, which are mainly
31 * called from the parser (in perly.y) as the code is parsed. For example
32 * the Perl code $a + $b * $c would cause the equivalent of the following
33 * to be called (oversimplifying a bit):
34 *
35 * newBINOP(OP_ADD, flags,
36 * newSVREF($a),
37 * newBINOP(OP_MULTIPLY, flags, newSVREF($b), newSVREF($c))
38 * )
39 *
40 * Note that during the build of miniperl, a temporary copy of this file
41 * is made, called opmini.c.
42 */
ccfc67b7 43
61b743bb
DM		 44/*
45Perl's compiler is essentially a 3-pass compiler with interleaved phases:
46
47 A bottom-up pass
48 A top-down pass
49 An execution-order pass
50
51The bottom-up pass is represented by all the "newOP" routines and
52the ck_ routines. The bottom-upness is actually driven by yacc.
53So at the point that a ck_ routine fires, we have no idea what the
54context is, either upward in the syntax tree, or either forward or
55backward in the execution order. (The bottom-up parser builds that
56part of the execution order it knows about, but if you follow the "next"
57links around, you'll find it's actually a closed loop through the
58top level node.
59
60Whenever the bottom-up parser gets to a node that supplies context to
61its components, it invokes that portion of the top-down pass that applies
62to that part of the subtree (and marks the top node as processed, so
63if a node further up supplies context, it doesn't have to take the
64plunge again). As a particular subcase of this, as the new node is
65built, it takes all the closed execution loops of its subcomponents
66and links them into a new closed loop for the higher level node. But
67it's still not the real execution order.
68
69The actual execution order is not known till we get a grammar reduction
70to a top-level unit like a subroutine or file that will be called by
71"name" rather than via a "next" pointer. At that point, we can call
72into peep() to do that code's portion of the 3rd pass. It has to be
73recursive, but it's recursive on basic blocks, not on tree nodes.
74*/
75
06e0342d 76/* To implement user lexical pragmas, there needs to be a way at run time to
b3ca2e83
NC		 77 get the compile time state of %^H for that block. Storing %^H in every
78 block (or even COP) would be very expensive, so a different approach is
79 taken. The (running) state of %^H is serialised into a tree of HE-like
80 structs. Stores into %^H are chained onto the current leaf as a struct
81 refcounted_he * with the key and the value. Deletes from %^H are saved
82 with a value of PL_sv_placeholder. The state of %^H at any point can be
83 turned back into a regular HV by walking back up the tree from that point's
06e0342d 84 leaf, ignoring any key you've already seen (placeholder or not), storing
b3ca2e83
NC		 85 the rest into the HV structure, then removing the placeholders. Hence
86 memory is only used to store the %^H deltas from the enclosing COP, rather
87 than the entire %^H on each COP.
88
89 To cause actions on %^H to write out the serialisation records, it has
90 magic type 'H'. This magic (itself) does nothing, but its presence causes
91 the values to gain magic type 'h', which has entries for set and clear.
c28fe1ec 92 C<Perl_magic_sethint> updates C<PL_compiling.cop_hints_hash> with a store
b3ca2e83 93 record, with deletes written by C<Perl_magic_clearhint>. C<SAVE_HINTS>
c28fe1ec
NC		 94 saves the current C<PL_compiling.cop_hints_hash> on the save stack, so that
95 it will be correctly restored when any inner compiling scope is exited.
b3ca2e83
NC		 96*/
97
79072805 98#include "EXTERN.h"
864dbfa3 99#define PERL_IN_OP_C
79072805 100#include "perl.h"
77ca0c92 101#include "keywords.h"
79072805 102
a07e034d 103#define CALL_PEEP(o) CALL_FPTR(PL_peepp)(aTHX_ o)
a2efc822 104
238a4c30
NIS		 105#if defined(PL_OP_SLAB_ALLOC)
106
107#ifndef PERL_SLAB_SIZE
108#define PERL_SLAB_SIZE 2048
109#endif
110
c7e45529
AE		 111void *
112Perl_Slab_Alloc(pTHX_ int m, size_t sz)
1c846c1f 113{
5a8e194f
NIS		 114 /*
115 * To make incrementing use count easy PL_OpSlab is an I32 *
116 * To make inserting the link to slab PL_OpPtr is I32 **
117 * So compute size in units of sizeof(I32 *) as that is how Pl_OpPtr increments
118 * Add an overhead for pointer to slab and round up as a number of pointers
119 */
120 sz = (sz + 2*sizeof(I32 *) -1)/sizeof(I32 *);
238a4c30 121 if ((PL_OpSpace -= sz) < 0) {
083fcd59
JH		 122 PL_OpPtr = (I32 **) PerlMemShared_malloc(PERL_SLAB_SIZE*sizeof(I32*));
123 if (!PL_OpPtr) {
238a4c30
NIS		 124 return NULL;
125 }
5a8e194f
NIS		 126 Zero(PL_OpPtr,PERL_SLAB_SIZE,I32 **);
127 /* We reserve the 0'th I32 sized chunk as a use count */
128 PL_OpSlab = (I32 *) PL_OpPtr;
129 /* Reduce size by the use count word, and by the size we need.
130 * Latter is to mimic the '-=' in the if() above
131 */
132 PL_OpSpace = PERL_SLAB_SIZE - (sizeof(I32)+sizeof(I32 **)-1)/sizeof(I32 **) - sz;
238a4c30
NIS		 133 /* Allocation pointer starts at the top.
134 Theory: because we build leaves before trunk allocating at end
135 means that at run time access is cache friendly upward
136 */
5a8e194f 137 PL_OpPtr += PERL_SLAB_SIZE;
238a4c30
NIS		 138 }
139 assert( PL_OpSpace >= 0 );
140 /* Move the allocation pointer down */
141 PL_OpPtr -= sz;
5a8e194f 142 assert( PL_OpPtr > (I32 **) PL_OpSlab );
238a4c30
NIS		 143 *PL_OpPtr = PL_OpSlab; /* Note which slab it belongs to */
144 (*PL_OpSlab)++; /* Increment use count of slab */
5a8e194f 145 assert( PL_OpPtr+sz <= ((I32 **) PL_OpSlab + PERL_SLAB_SIZE) );
238a4c30
NIS		 146 assert( *PL_OpSlab > 0 );
147 return (void *)(PL_OpPtr + 1);
148}
149
c7e45529
AE		 150void
151Perl_Slab_Free(pTHX_ void *op)
238a4c30 152{
551405c4 153 I32 * const * const ptr = (I32 **) op;
aec46f14 154 I32 * const slab = ptr[-1];
5a8e194f
NIS		 155 assert( ptr-1 > (I32 **) slab );
156 assert( ptr < ( (I32 **) slab + PERL_SLAB_SIZE) );
238a4c30
NIS		 157 assert( *slab > 0 );
158 if (--(*slab) == 0) {
7e4e8c89
NC		 159# ifdef NETWARE
160# define PerlMemShared PerlMem
161# endif
083fcd59
JH		 162
163 PerlMemShared_free(slab);
238a4c30
NIS		 164 if (slab == PL_OpSlab) {
165 PL_OpSpace = 0;
166 }
167 }
b7dc083c 168}
b7dc083c 169#endif
e50aee73 170/*
ce6f1cbc 171 * In the following definition, the ", (OP*)0" is just to make the compiler
a5f75d66 172 * think the expression is of the right type: croak actually does a Siglongjmp.
e50aee73 173 */
11343788 174#define CHECKOP(type,o) \
ce6f1cbc 175 ((PL_op_mask && PL_op_mask[type]) \
5dc0d613 176 ? ( op_free((OP*)o), \
cb77fdf0 177 Perl_croak(aTHX_ "'%s' trapped by operation mask", PL_op_desc[type]), \
ce6f1cbc 178 (OP*)0 ) \
fc0dc3b3 179 : CALL_FPTR(PL_check[type])(aTHX_ (OP*)o))
e50aee73 180
e6438c1a 181#define RETURN_UNLIMITED_NUMBER (PERL_INT_MAX / 2)
c53d7c7d 182
8b6b16e7 183STATIC const char*
cea2e8a9 184S_gv_ename(pTHX_ GV *gv)
4633a7c4 185{
46c461b5 186 SV* const tmpsv = sv_newmortal();
bd61b366 187 gv_efullname3(tmpsv, gv, NULL);
8b6b16e7 188 return SvPV_nolen_const(tmpsv);
4633a7c4
LW		 189}
190
76e3520e 191STATIC OP *
cea2e8a9 192S_no_fh_allowed(pTHX_ OP *o)
79072805 193{
cea2e8a9 194 yyerror(Perl_form(aTHX_ "Missing comma after first argument to %s function",
53e06cf0 195 OP_DESC(o)));
11343788 196 return o;
79072805
LW		 197}
198
76e3520e 199STATIC OP *
bfed75c6 200S_too_few_arguments(pTHX_ OP *o, const char *name)
79072805 201{
cea2e8a9 202 yyerror(Perl_form(aTHX_ "Not enough arguments for %s", name));
11343788 203 return o;
79072805
LW		 204}
205
76e3520e 206STATIC OP *
bfed75c6 207S_too_many_arguments(pTHX_ OP *o, const char *name)
79072805 208{
cea2e8a9 209 yyerror(Perl_form(aTHX_ "Too many arguments for %s", name));
11343788 210 return o;
79072805
LW		 211}
212
76e3520e 213STATIC void
6867be6d 214S_bad_type(pTHX_ I32 n, const char *t, const char *name, const OP *kid)
8990e307 215{
cea2e8a9 216 yyerror(Perl_form(aTHX_ "Type of arg %d to %s must be %s (not %s)",
53e06cf0 217 (int)n, name, t, OP_DESC(kid)));
8990e307
LW		 218}
219
7a52d87a 220STATIC void
6867be6d 221S_no_bareword_allowed(pTHX_ const OP *o)
7a52d87a 222{
eb8433b7
NC		 223 if (PL_madskills)
224 return; /* various ok barewords are hidden in extra OP_NULL */
5a844595 225 qerror(Perl_mess(aTHX_
35c1215d 226 "Bareword \"%"SVf"\" not allowed while \"strict subs\" in use",
95b63a38 227 (void*)cSVOPo_sv));
7a52d87a
GS		 228}
229
79072805
LW		 230/* "register" allocation */
231
232PADOFFSET
262cbcdb 233Perl_allocmy(pTHX_ const char *const name)
93a17b20 234{
97aff369 235 dVAR;
a0d0e21e 236 PADOFFSET off;
3edf23ff 237 const bool is_our = (PL_in_my == KEY_our);
a0d0e21e 238
59f00321 239 /* complain about "my $<special_var>" etc etc */
6b58708b 240 if (*name &&
3edf23ff 241 !(is_our ||
155aba94 242 isALPHA(name[1]) ||
39e02b42 243 (USE_UTF8_IN_NAMES && UTF8_IS_START(name[1])) ||
6b58708b 244 (name[1] == '_' && (*name == '$' || name[2]))))
834a4ddd 245 {
6b58708b 246 /* name[2] is true if strlen(name) > 2 */
c4d0567e 247 if (!isPRINT(name[1]) || strchr("\t\n\r\f", name[1])) {
d1544d85
NC		 248 yyerror(Perl_form(aTHX_ "Can't use global %c^%c%s in \"my\"",
249 name[0], toCTRL(name[1]), name + 2));
250 } else {
251 yyerror(Perl_form(aTHX_ "Can't use global %s in \"my\"",name));
46fc3d4c 252 }
a0d0e21e 253 }
748a9306 254
dd2155a4 255 /* check for duplicate declaration */
3edf23ff 256 pad_check_dup(name, is_our, (PL_curstash ? PL_curstash : PL_defstash));
33b8ce05 257
dd2155a4
DM		 258 if (PL_in_my_stash && *name != '$') {
259 yyerror(Perl_form(aTHX_
260 "Can't declare class for non-scalar %s in \"%s\"",
952306ac
RGS		 261 name,
262 is_our ? "our" : PL_in_my == KEY_state ? "state" : "my"));
6b35e009
GS		 263 }
264
dd2155a4 265 /* allocate a spare slot and store the name in that slot */
93a17b20 266
dd2155a4
DM		 267 off = pad_add_name(name,
268 PL_in_my_stash,
3edf23ff 269 (is_our
133706a6
RGS		 270 /* $_ is always in main::, even with our */
271 ? (PL_curstash && !strEQ(name,"$_") ? PL_curstash : PL_defstash)
5c284bb0 272 : NULL
dd2155a4 273 ),
952306ac
RGS		 274 0, /* not fake */
275 PL_in_my == KEY_state
dd2155a4
DM		 276 );
277 return off;
79072805
LW		 278}
279
79072805
LW		 280/* Destructor */
281
282void
864dbfa3 283Perl_op_free(pTHX_ OP *o)
79072805 284{
27da23d5 285 dVAR;
acb36ea4 286 OPCODE type;
79072805 287
2814eb74 288 if (!o || o->op_static)
79072805
LW		 289 return;
290
67566ccd 291 type = o->op_type;
7934575e 292 if (o->op_private & OPpREFCOUNTED) {
67566ccd 293 switch (type) {
7934575e
GS		 294 case OP_LEAVESUB:
295 case OP_LEAVESUBLV:
296 case OP_LEAVEEVAL:
297 case OP_LEAVE:
298 case OP_SCOPE:
299 case OP_LEAVEWRITE:
67566ccd
AL		 300 {
301 PADOFFSET refcnt;
7934575e 302 OP_REFCNT_LOCK;
4026c95a 303 refcnt = OpREFCNT_dec(o);
7934575e 304 OP_REFCNT_UNLOCK;
4026c95a
SH		 305 if (refcnt)
306 return;
67566ccd 307 }
7934575e
GS		 308 break;
309 default:
310 break;
311 }
312 }
313
11343788 314 if (o->op_flags & OPf_KIDS) {
6867be6d 315 register OP *kid, *nextkid;
11343788 316 for (kid = cUNOPo->op_first; kid; kid = nextkid) {
85e6fe83 317 nextkid = kid->op_sibling; /* Get before next freeing kid */
79072805 318 op_free(kid);
85e6fe83 319 }
79072805 320 }
acb36ea4 321 if (type == OP_NULL)
eb160463 322 type = (OPCODE)o->op_targ;
acb36ea4
GS		 323
324 /* COP* is not cleared by op_clear() so that we may track line
325 * numbers etc even after null() */
326 if (type == OP_NEXTSTATE || type == OP_SETSTATE || type == OP_DBSTATE)
327 cop_free((COP*)o);
328
329 op_clear(o);
238a4c30 330 FreeOp(o);
4d494880
DM		 331#ifdef DEBUG_LEAKING_SCALARS
332 if (PL_op == o)
5f66b61c 333 PL_op = NULL;
4d494880 334#endif
acb36ea4 335}
79072805 336
93c66552
DM		 337void
338Perl_op_clear(pTHX_ OP *o)
acb36ea4 339{
13137afc 340
27da23d5 341 dVAR;
eb8433b7
NC		 342#ifdef PERL_MAD
343 /* if (o->op_madprop && o->op_madprop->mad_next)
344 abort(); */
3cc8d589
NC		 345 /* FIXME for MAD - if I uncomment these two lines t/op/pack.t fails with
346 "modification of a read only value" for a reason I can't fathom why.
347 It's the "" stringification of $_, where $_ was set to '' in a foreach
04a4d38e
NC		 348 loop, but it defies simplification into a small test case.
349 However, commenting them out has caused ext/List/Util/t/weak.t to fail
350 the last test. */
3cc8d589
NC		 351 /*
352 mad_free(o->op_madprop);
353 o->op_madprop = 0;
354 */
eb8433b7
NC		 355#endif
356
357 retry:
11343788 358 switch (o->op_type) {
acb36ea4 359 case OP_NULL: /* Was holding old type, if any. */
eb8433b7
NC		 360 if (PL_madskills && o->op_targ != OP_NULL) {
361 o->op_type = o->op_targ;
362 o->op_targ = 0;
363 goto retry;
364 }
acb36ea4 365 case OP_ENTEREVAL: /* Was holding hints. */
acb36ea4 366 o->op_targ = 0;
a0d0e21e 367 break;
a6006777 368 default:
ac4c12e7 369 if (!(o->op_flags & OPf_REF)
0b94c7bb 370 || (PL_check[o->op_type] != MEMBER_TO_FPTR(Perl_ck_ftst)))
a6006777 371 break;
372 /* FALL THROUGH */
463ee0b2 373 case OP_GVSV:
79072805 374 case OP_GV:
a6006777 375 case OP_AELEMFAST:
6a077020
DM		 376 if (! (o->op_type == OP_AELEMFAST && o->op_flags & OPf_SPECIAL)) {
377 /* not an OP_PADAV replacement */
350de78d 378#ifdef USE_ITHREADS
6a077020
DM		 379 if (cPADOPo->op_padix > 0) {
380 /* No GvIN_PAD_off(cGVOPo_gv) here, because other references
381 * may still exist on the pad */
382 pad_swipe(cPADOPo->op_padix, TRUE);
383 cPADOPo->op_padix = 0;
384 }
350de78d 385#else
6a077020 386 SvREFCNT_dec(cSVOPo->op_sv);
a0714e2c 387 cSVOPo->op_sv = NULL;
350de78d 388#endif
6a077020 389 }
79072805 390 break;
a1ae71d2 391 case OP_METHOD_NAMED:
79072805 392 case OP_CONST:
11343788 393 SvREFCNT_dec(cSVOPo->op_sv);
a0714e2c 394 cSVOPo->op_sv = NULL;
3b1c21fa
AB		 395#ifdef USE_ITHREADS
396 /** Bug #15654
397 Even if op_clear does a pad_free for the target of the op,
6a077020 398 pad_free doesn't actually remove the sv that exists in the pad;
3b1c21fa
AB		 399 instead it lives on. This results in that it could be reused as
400 a target later on when the pad was reallocated.
401 **/
402 if(o->op_targ) {
403 pad_swipe(o->op_targ,1);
404 o->op_targ = 0;
405 }
406#endif
79072805 407 break;
748a9306
LW		 408 case OP_GOTO:
409 case OP_NEXT:
410 case OP_LAST:
411 case OP_REDO:
11343788 412 if (o->op_flags & (OPf_SPECIAL|OPf_STACKED|OPf_KIDS))
748a9306
LW		 413 break;
414 /* FALL THROUGH */
a0d0e21e 415 case OP_TRANS:
acb36ea4 416 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
a0ed51b3 417 SvREFCNT_dec(cSVOPo->op_sv);
a0714e2c 418 cSVOPo->op_sv = NULL;
acb36ea4
GS		 419 }
420 else {
a0ed51b3 421 Safefree(cPVOPo->op_pv);
bd61b366 422 cPVOPo->op_pv = NULL;
acb36ea4 423 }
a0d0e21e
LW		 424 break;
425 case OP_SUBST:
11343788 426 op_free(cPMOPo->op_pmreplroot);
971a9dd3 427 goto clear_pmop;
748a9306 428 case OP_PUSHRE:
971a9dd3 429#ifdef USE_ITHREADS
ba89bb6e 430 if (INT2PTR(PADOFFSET, cPMOPo->op_pmreplroot)) {
dd2155a4
DM		 431 /* No GvIN_PAD_off here, because other references may still
432 * exist on the pad */
433 pad_swipe(INT2PTR(PADOFFSET, cPMOPo->op_pmreplroot), TRUE);
971a9dd3
GS		 434 }
435#else
436 SvREFCNT_dec((SV*)cPMOPo->op_pmreplroot);
437#endif
438 /* FALL THROUGH */
a0d0e21e 439 case OP_MATCH:
8782bef2 440 case OP_QR:
971a9dd3 441clear_pmop:
cb55de95 442 {
551405c4 443 HV * const pmstash = PmopSTASH(cPMOPo);
0565a181 444 if (pmstash && !SvIS_FREED(pmstash)) {
551405c4 445 MAGIC * const mg = mg_find((SV*)pmstash, PERL_MAGIC_symtab);
8d2f4536
NC		 446 if (mg) {
447 PMOP *pmop = (PMOP*) mg->mg_obj;
448 PMOP *lastpmop = NULL;
449 while (pmop) {
450 if (cPMOPo == pmop) {
451 if (lastpmop)
452 lastpmop->op_pmnext = pmop->op_pmnext;
453 else
454 mg->mg_obj = (SV*) pmop->op_pmnext;
455 break;
456 }
457 lastpmop = pmop;
458 pmop = pmop->op_pmnext;
cb55de95 459 }
cb55de95 460 }
83da49e6 461 }
05ec9bb3 462 PmopSTASH_free(cPMOPo);
cb55de95 463 }
5f66b61c 464 cPMOPo->op_pmreplroot = NULL;
5f8cb046
DM		 465 /* we use the "SAFE" version of the PM_ macros here
466 * since sv_clean_all might release some PMOPs
467 * after PL_regex_padav has been cleared
468 * and the clearing of PL_regex_padav needs to
469 * happen before sv_clean_all
470 */
471 ReREFCNT_dec(PM_GETRE_SAFE(cPMOPo));
5f66b61c 472 PM_SETRE_SAFE(cPMOPo, NULL);
13137afc
AB		 473#ifdef USE_ITHREADS
474 if(PL_regex_pad) { /* We could be in destruction */
475 av_push((AV*) PL_regex_pad[0],(SV*) PL_regex_pad[(cPMOPo)->op_pmoffset]);
1cc8b4c5 476 SvREPADTMP_on(PL_regex_pad[(cPMOPo)->op_pmoffset]);
13137afc
AB		 477 PM_SETRE(cPMOPo, (cPMOPo)->op_pmoffset);
478 }
1eb1540c 479#endif
13137afc 480
a0d0e21e 481 break;
79072805
LW		 482 }
483
743e66e6 484 if (o->op_targ > 0) {
11343788 485 pad_free(o->op_targ);
743e66e6
GS		 486 o->op_targ = 0;
487 }
79072805
LW		 488}
489
76e3520e 490STATIC void
3eb57f73
HS		 491S_cop_free(pTHX_ COP* cop)
492{
c299b123
JH		 493 if (cop->cop_label) {
494#ifdef PERL_TRACK_MEMPOOL
495 Malloc_t ptr = (Malloc_t)(cop->cop_label - sTHX);
496 struct perl_memory_debug_header *const header
497 = (struct perl_memory_debug_header *)ptr;
498 /* Only the thread that allocated us can free us. */
499 if (header->interpreter == aTHX)
500#endif
b3123a61 501 {
c299b123 502 Safefree(cop->cop_label);
b3123a61
RGS		 503 cop->cop_label = NULL;
504 }
c299b123 505 }
05ec9bb3
NIS		 506 CopFILE_free(cop);
507 CopSTASH_free(cop);
0453d815 508 if (! specialWARN(cop->cop_warnings))
72dc9ed5 509 PerlMemShared_free(cop->cop_warnings);
c28fe1ec 510 Perl_refcounted_he_free(aTHX_ cop->cop_hints_hash);
3eb57f73
HS		 511}
512
93c66552
DM		 513void
514Perl_op_null(pTHX_ OP *o)
8990e307 515{
27da23d5 516 dVAR;
acb36ea4
GS		 517 if (o->op_type == OP_NULL)
518 return;
eb8433b7
NC		 519 if (!PL_madskills)
520 op_clear(o);
11343788
MB		 521 o->op_targ = o->op_type;
522 o->op_type = OP_NULL;
22c35a8c 523 o->op_ppaddr = PL_ppaddr[OP_NULL];
8990e307
LW		 524}
525
4026c95a
SH		 526void
527Perl_op_refcnt_lock(pTHX)
528{
27da23d5 529 dVAR;
96a5add6 530 PERL_UNUSED_CONTEXT;
4026c95a
SH		 531 OP_REFCNT_LOCK;
532}
533
534void
535Perl_op_refcnt_unlock(pTHX)
536{
27da23d5 537 dVAR;
96a5add6 538 PERL_UNUSED_CONTEXT;
4026c95a
SH		 539 OP_REFCNT_UNLOCK;
540}
541
79072805
LW		 542/* Contextualizers */
543
463ee0b2 544#define LINKLIST(o) ((o)->op_next ? (o)->op_next : linklist((OP*)o))
79072805
LW		 545
546OP *
864dbfa3 547Perl_linklist(pTHX_ OP *o)
79072805 548{
3edf23ff 549 OP *first;
79072805 550
11343788
MB		 551 if (o->op_next)
552 return o->op_next;
79072805
LW		 553
554 /* establish postfix order */
3edf23ff
AL		 555 first = cUNOPo->op_first;
556 if (first) {
6867be6d 557 register OP *kid;
3edf23ff
AL		 558 o->op_next = LINKLIST(first);
559 kid = first;
560 for (;;) {
561 if (kid->op_sibling) {
79072805 562 kid->op_next = LINKLIST(kid->op_sibling);
3edf23ff
AL		 563 kid = kid->op_sibling;
564 } else {
11343788 565 kid->op_next = o;
3edf23ff
AL		 566 break;
567 }
79072805
LW		 568 }
569 }
570 else
11343788 571 o->op_next = o;
79072805 572
11343788 573 return o->op_next;
79072805
LW		 574}
575
576OP *
864dbfa3 577Perl_scalarkids(pTHX_ OP *o)
79072805 578{
11343788 579 if (o && o->op_flags & OPf_KIDS) {
bfed75c6 580 OP *kid;
11343788 581 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
79072805
LW		 582 scalar(kid);
583 }
11343788 584 return o;
79072805
LW		 585}
586
76e3520e 587STATIC OP *
cea2e8a9 588S_scalarboolean(pTHX_ OP *o)
8990e307 589{
97aff369 590 dVAR;
d008e5eb 591 if (o->op_type == OP_SASSIGN && cBINOPo->op_first->op_type == OP_CONST) {
d008e5eb 592 if (ckWARN(WARN_SYNTAX)) {
6867be6d 593 const line_t oldline = CopLINE(PL_curcop);
a0d0e21e 594
d008e5eb 595 if (PL_copline != NOLINE)
57843af0 596 CopLINE_set(PL_curcop, PL_copline);
9014280d 597 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Found = in conditional, should be ==");
57843af0 598 CopLINE_set(PL_curcop, oldline);
d008e5eb 599 }
a0d0e21e 600 }
11343788 601 return scalar(o);
8990e307
LW		 602}
603
604OP *
864dbfa3 605Perl_scalar(pTHX_ OP *o)
79072805 606{
27da23d5 607 dVAR;
79072805
LW		 608 OP *kid;
609
a0d0e21e 610 /* assumes no premature commitment */
551405c4 611 if (!o || PL_error_count || (o->op_flags & OPf_WANT)
5dc0d613 612 || o->op_type == OP_RETURN)
7e363e51 613 {
11343788 614 return o;
7e363e51 615 }
79072805 616
5dc0d613 617 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_SCALAR;
79072805 618
11343788 619 switch (o->op_type) {
79072805 620 case OP_REPEAT:
11343788 621 scalar(cBINOPo->op_first);
8990e307 622 break;
79072805
LW		 623 case OP_OR:
624 case OP_AND:
625 case OP_COND_EXPR:
11343788 626 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
8990e307 627 scalar(kid);
79072805 628 break;
a0d0e21e 629 case OP_SPLIT:
11343788 630 if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) {
a0d0e21e 631 if (!kPMOP->op_pmreplroot)
12bcd1a6 632 deprecate_old("implicit split to @_");
a0d0e21e
LW		 633 }
634 /* FALL THROUGH */
79072805 635 case OP_MATCH:
8782bef2 636 case OP_QR:
79072805
LW		 637 case OP_SUBST:
638 case OP_NULL:
8990e307 639 default:
11343788
MB		 640 if (o->op_flags & OPf_KIDS) {
641 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
8990e307
LW		 642 scalar(kid);
643 }
79072805
LW		 644 break;
645 case OP_LEAVE:
646 case OP_LEAVETRY:
5dc0d613 647 kid = cLISTOPo->op_first;
54310121 648 scalar(kid);
155aba94 649 while ((kid = kid->op_sibling)) {
54310121 650 if (kid->op_sibling)
651 scalarvoid(kid);
652 else
653 scalar(kid);
654 }
11206fdd 655 PL_curcop = &PL_compiling;
54310121 656 break;
748a9306 657 case OP_SCOPE:
79072805 658 case OP_LINESEQ:
8990e307 659 case OP_LIST:
11343788 660 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
79072805
LW		 661 if (kid->op_sibling)
662 scalarvoid(kid);
663 else
664 scalar(kid);
665 }
11206fdd 666 PL_curcop = &PL_compiling;
79072805 667 break;
a801c63c
RGS		 668 case OP_SORT:
669 if (ckWARN(WARN_VOID))
9014280d 670 Perl_warner(aTHX_ packWARN(WARN_VOID), "Useless use of sort in scalar context");
79072805 671 }
11343788 672 return o;
79072805
LW		 673}
674
675OP *
864dbfa3 676Perl_scalarvoid(pTHX_ OP *o)
79072805 677{
27da23d5 678 dVAR;
79072805 679 OP *kid;
c445ea15 680 const char* useless = NULL;
8990e307 681 SV* sv;
2ebea0a1
GS		 682 U8 want;
683
eb8433b7
NC		 684 /* trailing mad null ops don't count as "there" for void processing */
685 if (PL_madskills &&
686 o->op_type != OP_NULL &&
687 o->op_sibling &&
688 o->op_sibling->op_type == OP_NULL)
689 {
690 OP *sib;
691 for (sib = o->op_sibling;
692 sib && sib->op_type == OP_NULL;
693 sib = sib->op_sibling) ;
694
695 if (!sib)
696 return o;
697 }
698
acb36ea4
GS		 699 if (o->op_type == OP_NEXTSTATE
700 || o->op_type == OP_SETSTATE
701 || o->op_type == OP_DBSTATE
702 || (o->op_type == OP_NULL && (o->op_targ == OP_NEXTSTATE
703 || o->op_targ == OP_SETSTATE
704 || o->op_targ == OP_DBSTATE)))
2ebea0a1 705 PL_curcop = (COP*)o; /* for warning below */
79072805 706
54310121 707 /* assumes no premature commitment */
2ebea0a1
GS		 708 want = o->op_flags & OPf_WANT;
709 if ((want && want != OPf_WANT_SCALAR) || PL_error_count
5dc0d613 710 || o->op_type == OP_RETURN)
7e363e51 711 {
11343788 712 return o;
7e363e51 713 }
79072805 714
b162f9ea 715 if ((o->op_private & OPpTARGET_MY)
7e363e51
GS		 716 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
717 {
b162f9ea 718 return scalar(o); /* As if inside SASSIGN */
7e363e51 719 }
1c846c1f 720
5dc0d613 721 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
79072805 722
11343788 723 switch (o->op_type) {
79072805 724 default:
22c35a8c 725 if (!(PL_opargs[o->op_type] & OA_FOLDCONST))
8990e307 726 break;
36477c24 727 /* FALL THROUGH */
728 case OP_REPEAT:
11343788 729 if (o->op_flags & OPf_STACKED)
8990e307 730 break;
5d82c453
GA		 731 goto func_ops;
732 case OP_SUBSTR:
733 if (o->op_private == 4)
734 break;
8990e307
LW		 735 /* FALL THROUGH */
736 case OP_GVSV:
737 case OP_WANTARRAY:
738 case OP_GV:
739 case OP_PADSV:
740 case OP_PADAV:
741 case OP_PADHV:
742 case OP_PADANY:
743 case OP_AV2ARYLEN:
8990e307 744 case OP_REF:
a0d0e21e
LW		 745 case OP_REFGEN:
746 case OP_SREFGEN:
8990e307
LW		 747 case OP_DEFINED:
748 case OP_HEX:
749 case OP_OCT:
750 case OP_LENGTH:
8990e307
LW		 751 case OP_VEC:
752 case OP_INDEX:
753 case OP_RINDEX:
754 case OP_SPRINTF:
755 case OP_AELEM:
756 case OP_AELEMFAST:
757 case OP_ASLICE:
8990e307
LW		 758 case OP_HELEM:
759 case OP_HSLICE:
760 case OP_UNPACK:
761 case OP_PACK:
8990e307
LW		 762 case OP_JOIN:
763 case OP_LSLICE:
764 case OP_ANONLIST:
765 case OP_ANONHASH:
766 case OP_SORT:
767 case OP_REVERSE:
768 case OP_RANGE:
769 case OP_FLIP:
770 case OP_FLOP:
771 case OP_CALLER:
772 case OP_FILENO:
773 case OP_EOF:
774 case OP_TELL:
775 case OP_GETSOCKNAME:
776 case OP_GETPEERNAME:
777 case OP_READLINK:
778 case OP_TELLDIR:
779 case OP_GETPPID:
780 case OP_GETPGRP:
781 case OP_GETPRIORITY:
782 case OP_TIME:
783 case OP_TMS:
784 case OP_LOCALTIME:
785 case OP_GMTIME:
786 case OP_GHBYNAME:
787 case OP_GHBYADDR:
788 case OP_GHOSTENT:
789 case OP_GNBYNAME:
790 case OP_GNBYADDR:
791 case OP_GNETENT:
792 case OP_GPBYNAME:
793 case OP_GPBYNUMBER:
794 case OP_GPROTOENT:
795 case OP_GSBYNAME:
796 case OP_GSBYPORT:
797 case OP_GSERVENT:
798 case OP_GPWNAM:
799 case OP_GPWUID:
800 case OP_GGRNAM:
801 case OP_GGRGID:
802 case OP_GETLOGIN:
78e1b766 803 case OP_PROTOTYPE:
5d82c453 804 func_ops:
64aac5a9 805 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))
53e06cf0 806 useless = OP_DESC(o);
8990e307
LW		 807 break;
808
9f82cd5f
YST		 809 case OP_NOT:
810 kid = cUNOPo->op_first;
811 if (kid->op_type != OP_MATCH && kid->op_type != OP_SUBST &&
812 kid->op_type != OP_TRANS) {
813 goto func_ops;
814 }
815 useless = "negative pattern binding (!~)";
816 break;
817
8990e307
LW		 818 case OP_RV2GV:
819 case OP_RV2SV:
820 case OP_RV2AV:
821 case OP_RV2HV:
192587c2 822 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)) &&
11343788 823 (!o->op_sibling || o->op_sibling->op_type != OP_READLINE))
8990e307
LW		 824 useless = "a variable";
825 break;
79072805
LW		 826
827 case OP_CONST:
7766f137 828 sv = cSVOPo_sv;
7a52d87a
GS		 829 if (cSVOPo->op_private & OPpCONST_STRICT)
830 no_bareword_allowed(o);
831 else {
d008e5eb
GS		 832 if (ckWARN(WARN_VOID)) {
833 useless = "a constant";
2e0ae2d3 834 if (o->op_private & OPpCONST_ARYBASE)
d4c19fe8 835 useless = NULL;
e7fec78e 836 /* don't warn on optimised away booleans, eg
b5a930ec 837 * use constant Foo, 5; Foo || print; */
e7fec78e 838 if (cSVOPo->op_private & OPpCONST_SHORTCIRCUIT)
d4c19fe8 839 useless = NULL;
960b4253
MG		 840 /* the constants 0 and 1 are permitted as they are
841 conventionally used as dummies in constructs like
842 1 while some_condition_with_side_effects; */
e7fec78e 843 else if (SvNIOK(sv) && (SvNV(sv) == 0.0 || SvNV(sv) == 1.0))
d4c19fe8 844 useless = NULL;
d008e5eb 845 else if (SvPOK(sv)) {
a52fe3ac
A		 846 /* perl4's way of mixing documentation and code
847 (before the invention of POD) was based on a
848 trick to mix nroff and perl code. The trick was
849 built upon these three nroff macros being used in
850 void context. The pink camel has the details in
851 the script wrapman near page 319. */
6136c704
AL		 852 const char * const maybe_macro = SvPVX_const(sv);
853 if (strnEQ(maybe_macro, "di", 2) ||
854 strnEQ(maybe_macro, "ds", 2) ||
855 strnEQ(maybe_macro, "ig", 2))
d4c19fe8 856 useless = NULL;
d008e5eb 857 }
8990e307
LW		 858 }
859 }
93c66552 860 op_null(o); /* don't execute or even remember it */
79072805
LW		 861 break;
862
863 case OP_POSTINC:
11343788 864 o->op_type = OP_PREINC; /* pre-increment is faster */
22c35a8c 865 o->op_ppaddr = PL_ppaddr[OP_PREINC];
79072805
LW		 866 break;
867
868 case OP_POSTDEC:
11343788 869 o->op_type = OP_PREDEC; /* pre-decrement is faster */
22c35a8c 870 o->op_ppaddr = PL_ppaddr[OP_PREDEC];
79072805
LW		 871 break;
872
679d6c4e
HS		 873 case OP_I_POSTINC:
874 o->op_type = OP_I_PREINC; /* pre-increment is faster */
875 o->op_ppaddr = PL_ppaddr[OP_I_PREINC];
876 break;
877
878 case OP_I_POSTDEC:
879 o->op_type = OP_I_PREDEC; /* pre-decrement is faster */
880 o->op_ppaddr = PL_ppaddr[OP_I_PREDEC];
881 break;
882
79072805
LW		 883 case OP_OR:
884 case OP_AND:
c963b151 885 case OP_DOR:
79072805 886 case OP_COND_EXPR:
0d863452
RH		 887 case OP_ENTERGIVEN:
888 case OP_ENTERWHEN:
11343788 889 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
79072805
LW		 890 scalarvoid(kid);
891 break;
5aabfad6 892
a0d0e21e 893 case OP_NULL:
11343788 894 if (o->op_flags & OPf_STACKED)
a0d0e21e 895 break;
5aabfad6 896 /* FALL THROUGH */
2ebea0a1
GS		 897 case OP_NEXTSTATE:
898 case OP_DBSTATE:
79072805
LW		 899 case OP_ENTERTRY:
900 case OP_ENTER:
11343788 901 if (!(o->op_flags & OPf_KIDS))
79072805 902 break;
54310121 903 /* FALL THROUGH */
463ee0b2 904 case OP_SCOPE:
79072805
LW		 905 case OP_LEAVE:
906 case OP_LEAVETRY:
a0d0e21e 907 case OP_LEAVELOOP:
79072805 908 case OP_LINESEQ:
79072805 909 case OP_LIST:
0d863452
RH		 910 case OP_LEAVEGIVEN:
911 case OP_LEAVEWHEN:
11343788 912 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
79072805
LW		 913 scalarvoid(kid);
914 break;
c90c0ff4 915 case OP_ENTEREVAL:
5196be3e 916 scalarkids(o);
c90c0ff4 917 break;
5aabfad6 918 case OP_REQUIRE:
c90c0ff4 919 /* all requires must return a boolean value */
5196be3e 920 o->op_flags &= ~OPf_WANT;
d6483035
GS		 921 /* FALL THROUGH */
922 case OP_SCALAR:
5196be3e 923 return scalar(o);
a0d0e21e 924 case OP_SPLIT:
11343788 925 if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) {
a0d0e21e 926 if (!kPMOP->op_pmreplroot)
12bcd1a6 927 deprecate_old("implicit split to @_");
a0d0e21e
LW		 928 }
929 break;
79072805 930 }
411caa50 931 if (useless && ckWARN(WARN_VOID))
9014280d 932 Perl_warner(aTHX_ packWARN(WARN_VOID), "Useless use of %s in void context", useless);
11343788 933 return o;
79072805
LW		 934}
935
936OP *
864dbfa3 937Perl_listkids(pTHX_ OP *o)
79072805 938{
11343788 939 if (o && o->op_flags & OPf_KIDS) {
6867be6d 940 OP *kid;
11343788 941 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
79072805
LW		 942 list(kid);
943 }
11343788 944 return o;
79072805
LW		 945}
946
947OP *
864dbfa3 948Perl_list(pTHX_ OP *o)
79072805 949{
27da23d5 950 dVAR;
79072805
LW		 951 OP *kid;
952
a0d0e21e 953 /* assumes no premature commitment */
3280af22 954 if (!o || (o->op_flags & OPf_WANT) || PL_error_count
5dc0d613 955 || o->op_type == OP_RETURN)
7e363e51 956 {
11343788 957 return o;
7e363e51 958 }
79072805 959
b162f9ea 960 if ((o->op_private & OPpTARGET_MY)
7e363e51
GS		 961 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
962 {
b162f9ea 963 return o; /* As if inside SASSIGN */
7e363e51 964 }
1c846c1f 965
5dc0d613 966 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_LIST;
79072805 967
11343788 968 switch (o->op_type) {
79072805
LW		 969 case OP_FLOP:
970 case OP_REPEAT:
11343788 971 list(cBINOPo->op_first);
79072805
LW		 972 break;
973 case OP_OR:
974 case OP_AND:
975 case OP_COND_EXPR:
11343788 976 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
79072805
LW		 977 list(kid);
978 break;
979 default:
980 case OP_MATCH:
8782bef2 981 case OP_QR:
79072805
LW		 982 case OP_SUBST:
983 case OP_NULL:
11343788 984 if (!(o->op_flags & OPf_KIDS))
79072805 985 break;
11343788
MB		 986 if (!o->op_next && cUNOPo->op_first->op_type == OP_FLOP) {
987 list(cBINOPo->op_first);
988 return gen_constant_list(o);
79072805
LW		 989 }
990 case OP_LIST:
11343788 991 listkids(o);
79072805
LW		 992 break;
993 case OP_LEAVE:
994 case OP_LEAVETRY:
5dc0d613 995 kid = cLISTOPo->op_first;
54310121 996 list(kid);
155aba94 997 while ((kid = kid->op_sibling)) {
54310121 998 if (kid->op_sibling)
999 scalarvoid(kid);
1000 else
1001 list(kid);
1002 }
11206fdd 1003 PL_curcop = &PL_compiling;
54310121 1004 break;
748a9306 1005 case OP_SCOPE:
79072805 1006 case OP_LINESEQ:
11343788 1007 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
79072805
LW		 1008 if (kid->op_sibling)
1009 scalarvoid(kid);
1010 else
1011 list(kid);
1012 }
11206fdd 1013 PL_curcop = &PL_compiling;
79072805 1014 break;
c90c0ff4 1015 case OP_REQUIRE:
1016 /* all requires must return a boolean value */
5196be3e
MB		 1017 o->op_flags &= ~OPf_WANT;
1018 return scalar(o);
79072805 1019 }
11343788 1020 return o;
79072805
LW		 1021}
1022
1023OP *
864dbfa3 1024Perl_scalarseq(pTHX_ OP *o)
79072805 1025{
97aff369 1026 dVAR;
11343788 1027 if (o) {
1496a290
AL		 1028 const OPCODE type = o->op_type;
1029
1030 if (type == OP_LINESEQ || type == OP_SCOPE ||
1031 type == OP_LEAVE || type == OP_LEAVETRY)
463ee0b2 1032 {
6867be6d 1033 OP *kid;
11343788 1034 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
ed6116ce 1035 if (kid->op_sibling) {
463ee0b2 1036 scalarvoid(kid);
ed6116ce 1037 }
463ee0b2 1038 }
3280af22 1039 PL_curcop = &PL_compiling;
79072805 1040 }
11343788 1041 o->op_flags &= ~OPf_PARENS;
3280af22 1042 if (PL_hints & HINT_BLOCK_SCOPE)
11343788 1043 o->op_flags |= OPf_PARENS;
79072805 1044 }
8990e307 1045 else
11343788
MB		 1046 o = newOP(OP_STUB, 0);
1047 return o;
79072805
LW		 1048}
1049
76e3520e 1050STATIC OP *
cea2e8a9 1051S_modkids(pTHX_ OP *o, I32 type)
79072805 1052{
11343788 1053 if (o && o->op_flags & OPf_KIDS) {
6867be6d 1054 OP *kid;
11343788 1055 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
463ee0b2 1056 mod(kid, type);
79072805 1057 }
11343788 1058 return o;
79072805
LW		 1059}
1060
ff7298cb 1061/* Propagate lvalue ("modifiable") context to an op and its children.
ddeae0f1
DM		 1062 * 'type' represents the context type, roughly based on the type of op that
1063 * would do the modifying, although local() is represented by OP_NULL.
1064 * It's responsible for detecting things that can't be modified, flag
1065 * things that need to behave specially in an lvalue context (e.g., "$$x = 5"
1066 * might have to vivify a reference in $x), and so on.
1067 *
1068 * For example, "$a+1 = 2" would cause mod() to be called with o being
1069 * OP_ADD and type being OP_SASSIGN, and would output an error.
1070 */
1071
79072805 1072OP *
864dbfa3 1073Perl_mod(pTHX_ OP *o, I32 type)
79072805 1074{
27da23d5 1075 dVAR;
79072805 1076 OP *kid;
ddeae0f1
DM		 1077 /* -1 = error on localize, 0 = ignore localize, 1 = ok to localize */
1078 int localize = -1;
79072805 1079
3280af22 1080 if (!o || PL_error_count)
11343788 1081 return o;
79072805 1082
b162f9ea 1083 if ((o->op_private & OPpTARGET_MY)
7e363e51
GS		 1084 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1085 {
b162f9ea 1086 return o;
7e363e51 1087 }
1c846c1f 1088
11343788 1089 switch (o->op_type) {
68dc0745 1090 case OP_UNDEF:
ddeae0f1 1091 localize = 0;
3280af22 1092 PL_modcount++;
5dc0d613 1093 return o;
a0d0e21e 1094 case OP_CONST:
2e0ae2d3 1095 if (!(o->op_private & OPpCONST_ARYBASE))
a0d0e21e 1096 goto nomod;
54dc0f91 1097 localize = 0;
3280af22 1098 if (PL_eval_start && PL_eval_start->op_type == OP_CONST) {
fc15ae8f
NC		 1099 CopARYBASE_set(&PL_compiling,
1100 (I32)SvIV(cSVOPx(PL_eval_start)->op_sv));
3280af22 1101 PL_eval_start = 0;
a0d0e21e
LW		 1102 }
1103 else if (!type) {
fc15ae8f
NC		 1104 SAVECOPARYBASE(&PL_compiling);
1105 CopARYBASE_set(&PL_compiling, 0);
a0d0e21e
LW		 1106 }
1107 else if (type == OP_REFGEN)
1108 goto nomod;
1109 else
cea2e8a9 1110 Perl_croak(aTHX_ "That use of $[ is unsupported");
a0d0e21e 1111 break;
5f05dabc 1112 case OP_STUB:
eb8433b7 1113 if (o->op_flags & OPf_PARENS || PL_madskills)
5f05dabc 1114 break;
1115 goto nomod;
a0d0e21e
LW		 1116 case OP_ENTERSUB:
1117 if ((type == OP_UNDEF || type == OP_REFGEN) &&
11343788
MB		 1118 !(o->op_flags & OPf_STACKED)) {
1119 o->op_type = OP_RV2CV; /* entersub => rv2cv */
e26df76a
NC		 1120 /* The default is to set op_private to the number of children,
1121 which for a UNOP such as RV2CV is always 1. And w're using
1122 the bit for a flag in RV2CV, so we need it clear. */
1123 o->op_private &= ~1;
22c35a8c 1124 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
11343788 1125 assert(cUNOPo->op_first->op_type == OP_NULL);
93c66552 1126 op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
79072805
LW		 1127 break;
1128 }
95f0a2f1
SB		 1129 else if (o->op_private & OPpENTERSUB_NOMOD)
1130 return o;
cd06dffe
GS		 1131 else { /* lvalue subroutine call */
1132 o->op_private |= OPpLVAL_INTRO;
e6438c1a 1133 PL_modcount = RETURN_UNLIMITED_NUMBER;
4978d6d9 1134 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN) {
cd06dffe
GS		 1135 /* Backward compatibility mode: */
1136 o->op_private |= OPpENTERSUB_INARGS;
1137 break;
1138 }
1139 else { /* Compile-time error message: */
1140 OP *kid = cUNOPo->op_first;
1141 CV *cv;
1142 OP *okid;
1143
3ea285d1
AL		 1144 if (kid->op_type != OP_PUSHMARK) {
1145 if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
1146 Perl_croak(aTHX_
1147 "panic: unexpected lvalue entersub "
1148 "args: type/targ %ld:%"UVuf,
1149 (long)kid->op_type, (UV)kid->op_targ);
1150 kid = kLISTOP->op_first;
1151 }
cd06dffe
GS		 1152 while (kid->op_sibling)
1153 kid = kid->op_sibling;
1154 if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) {
1155 /* Indirect call */
1156 if (kid->op_type == OP_METHOD_NAMED
1157 || kid->op_type == OP_METHOD)
1158 {
87d7fd28 1159 UNOP *newop;
b2ffa427 1160
87d7fd28 1161 NewOp(1101, newop, 1, UNOP);
349fd7b7
GS		 1162 newop->op_type = OP_RV2CV;
1163 newop->op_ppaddr = PL_ppaddr[OP_RV2CV];
5f66b61c 1164 newop->op_first = NULL;
87d7fd28
GS		 1165 newop->op_next = (OP*)newop;
1166 kid->op_sibling = (OP*)newop;
349fd7b7 1167 newop->op_private |= OPpLVAL_INTRO;
e26df76a 1168 newop->op_private &= ~1;
cd06dffe
GS		 1169 break;
1170 }
b2ffa427 1171
cd06dffe
GS		 1172 if (kid->op_type != OP_RV2CV)
1173 Perl_croak(aTHX_
1174 "panic: unexpected lvalue entersub "
55140b79 1175 "entry via type/targ %ld:%"UVuf,
3d811634 1176 (long)kid->op_type, (UV)kid->op_targ);
cd06dffe
GS		 1177 kid->op_private |= OPpLVAL_INTRO;
1178 break; /* Postpone until runtime */
1179 }
b2ffa427
NIS		 1180
1181 okid = kid;
cd06dffe
GS		 1182 kid = kUNOP->op_first;
1183 if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV)
1184 kid = kUNOP->op_first;
b2ffa427 1185 if (kid->op_type == OP_NULL)
cd06dffe
GS		 1186 Perl_croak(aTHX_
1187 "Unexpected constant lvalue entersub "
55140b79 1188 "entry via type/targ %ld:%"UVuf,
3d811634 1189 (long)kid->op_type, (UV)kid->op_targ);
cd06dffe
GS		 1190 if (kid->op_type != OP_GV) {
1191 /* Restore RV2CV to check lvalueness */
1192 restore_2cv:
1193 if (kid->op_next && kid->op_next != kid) { /* Happens? */
1194 okid->op_next = kid->op_next;
1195 kid->op_next = okid;
1196 }
1197 else
5f66b61c 1198 okid->op_next = NULL;
cd06dffe
GS		 1199 okid->op_type = OP_RV2CV;
1200 okid->op_targ = 0;
1201 okid->op_ppaddr = PL_ppaddr[OP_RV2CV];
1202 okid->op_private |= OPpLVAL_INTRO;
e26df76a 1203 okid->op_private &= ~1;
cd06dffe
GS		 1204 break;
1205 }
b2ffa427 1206
638eceb6 1207 cv = GvCV(kGVOP_gv);
1c846c1f 1208 if (!cv)
cd06dffe
GS		 1209 goto restore_2cv;
1210 if (CvLVALUE(cv))
1211 break;
1212 }
1213 }
79072805
LW		 1214 /* FALL THROUGH */
1215 default:
a0d0e21e 1216 nomod:
6fbb66d6
NC		 1217 /* grep, foreach, subcalls, refgen */
1218 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN)
a0d0e21e 1219 break;
cea2e8a9 1220 yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
638bc118 1221 (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
cd06dffe
GS		 1222 ? "do block"
1223 : (o->op_type == OP_ENTERSUB
1224 ? "non-lvalue subroutine call"
53e06cf0 1225 : OP_DESC(o))),
22c35a8c 1226 type ? PL_op_desc[type] : "local"));
11343788 1227 return o;
79072805 1228
a0d0e21e
LW		 1229 case OP_PREINC:
1230 case OP_PREDEC:
1231 case OP_POW:
1232 case OP_MULTIPLY:
1233 case OP_DIVIDE:
1234 case OP_MODULO:
1235 case OP_REPEAT:
1236 case OP_ADD:
1237 case OP_SUBTRACT:
1238 case OP_CONCAT:
1239 case OP_LEFT_SHIFT:
1240 case OP_RIGHT_SHIFT:
1241 case OP_BIT_AND:
1242 case OP_BIT_XOR:
1243 case OP_BIT_OR:
1244 case OP_I_MULTIPLY:
1245 case OP_I_DIVIDE:
1246 case OP_I_MODULO:
1247 case OP_I_ADD:
1248 case OP_I_SUBTRACT:
11343788 1249 if (!(o->op_flags & OPf_STACKED))
a0d0e21e 1250 goto nomod;
3280af22 1251 PL_modcount++;
a0d0e21e 1252 break;
b2ffa427 1253
79072805 1254 case OP_COND_EXPR:
ddeae0f1 1255 localize = 1;
11343788 1256 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
463ee0b2 1257 mod(kid, type);
79072805
LW		 1258 break;
1259
1260 case OP_RV2AV:
1261 case OP_RV2HV:
11343788 1262 if (type == OP_REFGEN && o->op_flags & OPf_PARENS) {
e6438c1a 1263 PL_modcount = RETURN_UNLIMITED_NUMBER;
11343788 1264 return o; /* Treat \(@foo) like ordinary list. */
748a9306
LW		 1265 }
1266 /* FALL THROUGH */
79072805 1267 case OP_RV2GV:
5dc0d613 1268 if (scalar_mod_type(o, type))
3fe9a6f1 1269 goto nomod;
11343788 1270 ref(cUNOPo->op_first, o->op_type);
79072805 1271 /* FALL THROUGH */
79072805
LW		 1272 case OP_ASLICE:
1273 case OP_HSLICE:
78f9721b
SM		 1274 if (type == OP_LEAVESUBLV)
1275 o->op_private |= OPpMAYBE_LVSUB;
ddeae0f1 1276 localize = 1;
78f9721b
SM		 1277 /* FALL THROUGH */
1278 case OP_AASSIGN:
93a17b20
LW		 1279 case OP_NEXTSTATE:
1280 case OP_DBSTATE:
e6438c1a 1281 PL_modcount = RETURN_UNLIMITED_NUMBER;
79072805 1282 break;
463ee0b2 1283 case OP_RV2SV:
aeea060c 1284 ref(cUNOPo->op_first, o->op_type);
ddeae0f1 1285 localize = 1;
463ee0b2 1286 /* FALL THROUGH */
79072805 1287 case OP_GV:
463ee0b2 1288 case OP_AV2ARYLEN:
3280af22 1289 PL_hints |= HINT_BLOCK_SCOPE;
463ee0b2 1290 case OP_SASSIGN:
bf4b1e52
GS		 1291 case OP_ANDASSIGN:
1292 case OP_ORASSIGN:
c963b151 1293 case OP_DORASSIGN:
ddeae0f1
DM		 1294 PL_modcount++;
1295 break;
1296
8990e307 1297 case OP_AELEMFAST:
6a077020 1298 localize = -1;
3280af22 1299 PL_modcount++;
8990e307
LW		 1300 break;
1301
748a9306
LW		 1302 case OP_PADAV:
1303 case OP_PADHV:
e6438c1a 1304 PL_modcount = RETURN_UNLIMITED_NUMBER;
5196be3e
MB		 1305 if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
1306 return o; /* Treat \(@foo) like ordinary list. */
1307 if (scalar_mod_type(o, type))
3fe9a6f1 1308 goto nomod;
78f9721b
SM		 1309 if (type == OP_LEAVESUBLV)
1310 o->op_private |= OPpMAYBE_LVSUB;
748a9306
LW		 1311 /* FALL THROUGH */
1312 case OP_PADSV:
3280af22 1313 PL_modcount++;
ddeae0f1 1314 if (!type) /* local() */
cea2e8a9 1315 Perl_croak(aTHX_ "Can't localize lexical variable %s",
dd2155a4 1316 PAD_COMPNAME_PV(o->op_targ));
463ee0b2
LW		 1317 break;
1318
748a9306 1319 case OP_PUSHMARK:
ddeae0f1 1320 localize = 0;
748a9306 1321 break;
b2ffa427 1322
69969c6f
SB		 1323 case OP_KEYS:
1324 if (type != OP_SASSIGN)
1325 goto nomod;
5d82c453
GA		 1326 goto lvalue_func;
1327 case OP_SUBSTR:
1328 if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */
1329 goto nomod;
5f05dabc 1330 /* FALL THROUGH */
a0d0e21e 1331 case OP_POS:
463ee0b2 1332 case OP_VEC:
78f9721b
SM		 1333 if (type == OP_LEAVESUBLV)
1334 o->op_private |= OPpMAYBE_LVSUB;
5d82c453 1335 lvalue_func:
11343788
MB		 1336 pad_free(o->op_targ);
1337 o->op_targ = pad_alloc(o->op_type, SVs_PADMY);
5dc0d613 1338 assert(SvTYPE(PAD_SV(o->op_targ)) == SVt_NULL);
11343788
MB		 1339 if (o->op_flags & OPf_KIDS)
1340 mod(cBINOPo->op_first->op_sibling, type);
463ee0b2 1341 break;
a0d0e21e 1342
463ee0b2
LW		 1343 case OP_AELEM:
1344 case OP_HELEM:
11343788 1345 ref(cBINOPo->op_first, o->op_type);
68dc0745 1346 if (type == OP_ENTERSUB &&
5dc0d613
MB		 1347 !(o->op_private & (OPpLVAL_INTRO | OPpDEREF)))
1348 o->op_private |= OPpLVAL_DEFER;
78f9721b
SM		 1349 if (type == OP_LEAVESUBLV)
1350 o->op_private |= OPpMAYBE_LVSUB;
ddeae0f1 1351 localize = 1;
3280af22 1352 PL_modcount++;
463ee0b2
LW		 1353 break;
1354
1355 case OP_SCOPE:
1356 case OP_LEAVE:
1357 case OP_ENTER:
78f9721b 1358 case OP_LINESEQ:
ddeae0f1 1359 localize = 0;
11343788
MB		 1360 if (o->op_flags & OPf_KIDS)
1361 mod(cLISTOPo->op_last, type);
a0d0e21e
LW		 1362 break;
1363
1364 case OP_NULL:
ddeae0f1 1365 localize = 0;
638bc118
GS		 1366 if (o->op_flags & OPf_SPECIAL) /* do BLOCK */
1367 goto nomod;
1368 else if (!(o->op_flags & OPf_KIDS))
463ee0b2 1369 break;
11343788
MB		 1370 if (o->op_targ != OP_LIST) {
1371 mod(cBINOPo->op_first, type);
a0d0e21e
LW		 1372 break;
1373 }
1374 /* FALL THROUGH */
463ee0b2 1375 case OP_LIST:
ddeae0f1 1376 localize = 0;
11343788 1377 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
463ee0b2
LW		 1378 mod(kid, type);
1379 break;
78f9721b
SM		 1380
1381 case OP_RETURN:
1382 if (type != OP_LEAVESUBLV)
1383 goto nomod;
1384 break; /* mod()ing was handled by ck_return() */
463ee0b2 1385 }
58d95175 1386
8be1be90
AMS		 1387 /* [20011101.069] File test operators interpret OPf_REF to mean that
1388 their argument is a filehandle; thus \stat(".") should not set
1389 it. AMS 20011102 */
1390 if (type == OP_REFGEN &&
1391 PL_check[o->op_type] == MEMBER_TO_FPTR(Perl_ck_ftst))
1392 return o;
1393
1394 if (type != OP_LEAVESUBLV)
1395 o->op_flags |= OPf_MOD;
1396
1397 if (type == OP_AASSIGN || type == OP_SASSIGN)
1398 o->op_flags |= OPf_SPECIAL|OPf_REF;
ddeae0f1
DM		 1399 else if (!type) { /* local() */
1400 switch (localize) {
1401 case 1:
1402 o->op_private |= OPpLVAL_INTRO;
1403 o->op_flags &= ~OPf_SPECIAL;
1404 PL_hints |= HINT_BLOCK_SCOPE;
1405 break;
1406 case 0:
1407 break;
1408 case -1:
1409 if (ckWARN(WARN_SYNTAX)) {
1410 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1411 "Useless localization of %s", OP_DESC(o));
1412 }
1413 }
463ee0b2 1414 }
8be1be90
AMS		 1415 else if (type != OP_GREPSTART && type != OP_ENTERSUB
1416 && type != OP_LEAVESUBLV)
1417 o->op_flags |= OPf_REF;
11343788 1418 return o;
463ee0b2
LW		 1419}
1420
864dbfa3 1421STATIC bool
5f66b61c 1422S_scalar_mod_type(const OP *o, I32 type)
3fe9a6f1 1423{
1424 switch (type) {
1425 case OP_SASSIGN:
5196be3e 1426 if (o->op_type == OP_RV2GV)
3fe9a6f1 1427 return FALSE;
1428 /* FALL THROUGH */
1429 case OP_PREINC:
1430 case OP_PREDEC:
1431 case OP_POSTINC:
1432 case OP_POSTDEC:
1433 case OP_I_PREINC:
1434 case OP_I_PREDEC:
1435 case OP_I_POSTINC:
1436 case OP_I_POSTDEC:
1437 case OP_POW:
1438 case OP_MULTIPLY:
1439 case OP_DIVIDE:
1440 case OP_MODULO:
1441 case OP_REPEAT:
1442 case OP_ADD:
1443 case OP_SUBTRACT:
1444 case OP_I_MULTIPLY:
1445 case OP_I_DIVIDE:
1446 case OP_I_MODULO:
1447 case OP_I_ADD:
1448 case OP_I_SUBTRACT:
1449 case OP_LEFT_SHIFT:
1450 case OP_RIGHT_SHIFT:
1451 case OP_BIT_AND:
1452 case OP_BIT_XOR:
1453 case OP_BIT_OR:
1454 case OP_CONCAT:
1455 case OP_SUBST:
1456 case OP_TRANS:
49e9fbe6
GS		 1457 case OP_READ:
1458 case OP_SYSREAD:
1459 case OP_RECV:
bf4b1e52
GS		 1460 case OP_ANDASSIGN:
1461 case OP_ORASSIGN:
3fe9a6f1 1462 return TRUE;
1463 default:
1464 return FALSE;
1465 }
1466}
1467
35cd451c 1468STATIC bool
5f66b61c 1469S_is_handle_constructor(const OP *o, I32 numargs)
35cd451c
GS		 1470{
1471 switch (o->op_type) {
1472 case OP_PIPE_OP:
1473 case OP_SOCKPAIR:
504618e9 1474 if (numargs == 2)
35cd451c
GS		 1475 return TRUE;
1476 /* FALL THROUGH */
1477 case OP_SYSOPEN:
1478 case OP_OPEN:
ded8aa31 1479 case OP_SELECT: /* XXX c.f. SelectSaver.pm */
35cd451c
GS		 1480 case OP_SOCKET:
1481 case OP_OPEN_DIR:
1482 case OP_ACCEPT:
504618e9 1483 if (numargs == 1)
35cd451c 1484 return TRUE;
5f66b61c 1485 /* FALLTHROUGH */
35cd451c
GS		 1486 default:
1487 return FALSE;
1488 }
1489}
1490
463ee0b2 1491OP *
864dbfa3 1492Perl_refkids(pTHX_ OP *o, I32 type)
463ee0b2 1493{
11343788 1494 if (o && o->op_flags & OPf_KIDS) {
6867be6d 1495 OP *kid;
11343788 1496 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
463ee0b2
LW		 1497 ref(kid, type);
1498 }
11343788 1499 return o;
463ee0b2
LW		 1500}
1501
1502OP *
e4c5ccf3 1503Perl_doref(pTHX_ OP *o, I32 type, bool set_op_ref)
463ee0b2 1504{
27da23d5 1505 dVAR;
463ee0b2 1506 OP *kid;
463ee0b2 1507
3280af22 1508 if (!o || PL_error_count)
11343788 1509 return o;
463ee0b2 1510
11343788 1511 switch (o->op_type) {
a0d0e21e 1512 case OP_ENTERSUB:
afebc493 1513 if ((type == OP_EXISTS || type == OP_DEFINED || type == OP_LOCK) &&
11343788
MB		 1514 !(o->op_flags & OPf_STACKED)) {
1515 o->op_type = OP_RV2CV; /* entersub => rv2cv */
22c35a8c 1516 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
11343788 1517 assert(cUNOPo->op_first->op_type == OP_NULL);
93c66552 1518 op_null(((LISTOP*)cUNOPo->op_first)->op_first); /* disable pushmark */
11343788 1519 o->op_flags |= OPf_SPECIAL;
e26df76a 1520 o->op_private &= ~1;
8990e307
LW		 1521 }
1522 break;
aeea060c 1523
463ee0b2 1524 case OP_COND_EXPR:
11343788 1525 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
e4c5ccf3 1526 doref(kid, type, set_op_ref);
463ee0b2 1527 break;
8990e307 1528 case OP_RV2SV:
35cd451c
GS		 1529 if (type == OP_DEFINED)
1530 o->op_flags |= OPf_SPECIAL; /* don't create GV */
e4c5ccf3 1531 doref(cUNOPo->op_first, o->op_type, set_op_ref);
4633a7c4
LW		 1532 /* FALL THROUGH */
1533 case OP_PADSV:
5f05dabc 1534 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
5dc0d613
MB		 1535 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1536 : type == OP_RV2HV ? OPpDEREF_HV
1537 : OPpDEREF_SV);
11343788 1538 o->op_flags |= OPf_MOD;
a0d0e21e 1539 }
8990e307 1540 break;
1c846c1f 1541
2faa37cc 1542 case OP_THREADSV:
a863c7d1
MB		 1543 o->op_flags |= OPf_MOD; /* XXX ??? */
1544 break;
1545
463ee0b2
LW		 1546 case OP_RV2AV:
1547 case OP_RV2HV:
e4c5ccf3
RH		 1548 if (set_op_ref)
1549 o->op_flags |= OPf_REF;
8990e307 1550 /* FALL THROUGH */
463ee0b2 1551 case OP_RV2GV:
35cd451c
GS		 1552 if (type == OP_DEFINED)
1553 o->op_flags |= OPf_SPECIAL; /* don't create GV */
e4c5ccf3 1554 doref(cUNOPo->op_first, o->op_type, set_op_ref);
463ee0b2 1555 break;
8990e307 1556
463ee0b2
LW		 1557 case OP_PADAV:
1558 case OP_PADHV:
e4c5ccf3
RH		 1559 if (set_op_ref)
1560 o->op_flags |= OPf_REF;
79072805 1561 break;
aeea060c 1562
8990e307 1563 case OP_SCALAR:
79072805 1564 case OP_NULL:
11343788 1565 if (!(o->op_flags & OPf_KIDS))
463ee0b2 1566 break;
e4c5ccf3 1567 doref(cBINOPo->op_first, type, set_op_ref);
79072805
LW		 1568 break;
1569 case OP_AELEM:
1570 case OP_HELEM:
e4c5ccf3 1571 doref(cBINOPo->op_first, o->op_type, set_op_ref);
5f05dabc 1572 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
5dc0d613
MB		 1573 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1574 : type == OP_RV2HV ? OPpDEREF_HV
1575 : OPpDEREF_SV);
11343788 1576 o->op_flags |= OPf_MOD;
8990e307 1577 }
79072805
LW		 1578 break;
1579
463ee0b2 1580 case OP_SCOPE:
79072805 1581 case OP_LEAVE:
e4c5ccf3
RH		 1582 set_op_ref = FALSE;
1583 /* FALL THROUGH */
79072805 1584 case OP_ENTER:
8990e307 1585 case OP_LIST:
11343788 1586 if (!(o->op_flags & OPf_KIDS))
79072805 1587 break;
e4c5ccf3 1588 doref(cLISTOPo->op_last, type, set_op_ref);
79072805 1589 break;
a0d0e21e
LW		 1590 default:
1591 break;
79072805 1592 }
11343788 1593 return scalar(o);
8990e307 1594
79072805
LW		 1595}
1596
09bef843
SB		 1597STATIC OP *
1598S_dup_attrlist(pTHX_ OP *o)
1599{
97aff369 1600 dVAR;
0bd48802 1601 OP *rop;
09bef843
SB		 1602
1603 /* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
1604 * where the first kid is OP_PUSHMARK and the remaining ones
1605 * are OP_CONST. We need to push the OP_CONST values.
1606 */
1607 if (o->op_type == OP_CONST)
b37c2d43 1608 rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc_NN(cSVOPo->op_sv));
eb8433b7
NC		 1609#ifdef PERL_MAD
1610 else if (o->op_type == OP_NULL)
1d866c12 1611 rop = NULL;
eb8433b7 1612#endif
09bef843
SB		 1613 else {
1614 assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
5f66b61c 1615 rop = NULL;
09bef843
SB		 1616 for (o = cLISTOPo->op_first; o; o=o->op_sibling) {
1617 if (o->op_type == OP_CONST)
1618 rop = append_elem(OP_LIST, rop,
1619 newSVOP(OP_CONST, o->op_flags,
b37c2d43 1620 SvREFCNT_inc_NN(cSVOPo->op_sv)));
09bef843
SB		 1621 }
1622 }
1623 return rop;
1624}
1625
1626STATIC void
95f0a2f1 1627S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs, bool for_my)
09bef843 1628{
27da23d5 1629 dVAR;
09bef843
SB		 1630 SV *stashsv;
1631
1632 /* fake up C<use attributes $pkg,$rv,@attrs> */
1633 ENTER; /* need to protect against side-effects of 'use' */
1634 SAVEINT(PL_expect);
5aaec2b4 1635 stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
e4783991 1636
09bef843 1637#define ATTRSMODULE "attributes"
95f0a2f1
SB		 1638#define ATTRSMODULE_PM "attributes.pm"
1639
1640 if (for_my) {
95f0a2f1 1641 /* Don't force the C<use> if we don't need it. */
a4fc7abc 1642 SV * const * const svp = hv_fetchs(GvHVn(PL_incgv), ATTRSMODULE_PM, FALSE);
95f0a2f1 1643 if (svp && *svp != &PL_sv_undef)
6f207bd3 1644 NOOP; /* already in %INC */
95f0a2f1
SB		 1645 else
1646 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
6136c704 1647 newSVpvs(ATTRSMODULE), NULL);
95f0a2f1
SB		 1648 }
1649 else {
1650 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
6136c704
AL		 1651 newSVpvs(ATTRSMODULE),
1652 NULL,
95f0a2f1
SB		 1653 prepend_elem(OP_LIST,
1654 newSVOP(OP_CONST, 0, stashsv),
1655 prepend_elem(OP_LIST,
1656 newSVOP(OP_CONST, 0,
1657 newRV(target)),
1658 dup_attrlist(attrs))));
1659 }
09bef843
SB		 1660 LEAVE;
1661}
1662
95f0a2f1
SB		 1663STATIC void
1664S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp)
1665{
97aff369 1666 dVAR;
95f0a2f1
SB		 1667 OP *pack, *imop, *arg;
1668 SV *meth, *stashsv;
1669
1670 if (!attrs)
1671 return;
1672
1673 assert(target->op_type == OP_PADSV ||
1674 target->op_type == OP_PADHV ||
1675 target->op_type == OP_PADAV);
1676
1677 /* Ensure that attributes.pm is loaded. */
dd2155a4 1678 apply_attrs(stash, PAD_SV(target->op_targ), attrs, TRUE);
95f0a2f1
SB		 1679
1680 /* Need package name for method call. */
6136c704 1681 pack = newSVOP(OP_CONST, 0, newSVpvs(ATTRSMODULE));
95f0a2f1
SB		 1682
1683 /* Build up the real arg-list. */
5aaec2b4
NC		 1684 stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
1685
95f0a2f1
SB		 1686 arg = newOP(OP_PADSV, 0);
1687 arg->op_targ = target->op_targ;
1688 arg = prepend_elem(OP_LIST,
1689 newSVOP(OP_CONST, 0, stashsv),
1690 prepend_elem(OP_LIST,
1691 newUNOP(OP_REFGEN, 0,
1692 mod(arg, OP_REFGEN)),
1693 dup_attrlist(attrs)));
1694
1695 /* Fake up a method call to import */
18916d0d 1696 meth = newSVpvs_share("import");
95f0a2f1
SB		 1697 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL|OPf_WANT_VOID,
1698 append_elem(OP_LIST,
1699 prepend_elem(OP_LIST, pack, list(arg)),
1700 newSVOP(OP_METHOD_NAMED, 0, meth)));
1701 imop->op_private |= OPpENTERSUB_NOMOD;
1702
1703 /* Combine the ops. */
1704 *imopsp = append_elem(OP_LIST, *imopsp, imop);
1705}
1706
1707/*
1708=notfor apidoc apply_attrs_string
1709
1710Attempts to apply a list of attributes specified by the C<attrstr> and
1711C<len> arguments to the subroutine identified by the C<cv> argument which
1712is expected to be associated with the package identified by the C<stashpv>
1713argument (see L<attributes>). It gets this wrong, though, in that it
1714does not correctly identify the boundaries of the individual attribute
1715specifications within C<attrstr>. This is not really intended for the
1716public API, but has to be listed here for systems such as AIX which
1717need an explicit export list for symbols. (It's called from XS code
1718in support of the C<ATTRS:> keyword from F<xsubpp>.) Patches to fix it
1719to respect attribute syntax properly would be welcome.
1720
1721=cut
1722*/
1723
be3174d2 1724void
6867be6d
AL		 1725Perl_apply_attrs_string(pTHX_ const char *stashpv, CV *cv,
1726 const char *attrstr, STRLEN len)
be3174d2 1727{
5f66b61c 1728 OP *attrs = NULL;
be3174d2
GS		 1729
1730 if (!len) {
1731 len = strlen(attrstr);
1732 }
1733
1734 while (len) {
1735 for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
1736 if (len) {
890ce7af 1737 const char * const sstr = attrstr;
be3174d2
GS		 1738 for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
1739 attrs = append_elem(OP_LIST, attrs,
1740 newSVOP(OP_CONST, 0,
1741 newSVpvn(sstr, attrstr-sstr)));
1742 }
1743 }
1744
1745 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
6136c704 1746 newSVpvs(ATTRSMODULE),
a0714e2c 1747 NULL, prepend_elem(OP_LIST,
be3174d2
GS		 1748 newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
1749 prepend_elem(OP_LIST,
1750 newSVOP(OP_CONST, 0,
1751 newRV((SV*)cv)),
1752 attrs)));
1753}
1754
09bef843 1755STATIC OP *
95f0a2f1 1756S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp)
93a17b20 1757{
97aff369 1758 dVAR;
93a17b20
LW		 1759 I32 type;
1760
3280af22 1761 if (!o || PL_error_count)
11343788 1762 return o;
93a17b20 1763
bc61e325 1764 type = o->op_type;
eb8433b7
NC		 1765 if (PL_madskills && type == OP_NULL && o->op_flags & OPf_KIDS) {
1766 (void)my_kid(cUNOPo->op_first, attrs, imopsp);
1767 return o;
1768 }
1769
93a17b20 1770 if (type == OP_LIST) {
6867be6d 1771 OP *kid;
11343788 1772 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
95f0a2f1 1773 my_kid(kid, attrs, imopsp);
eb8433b7
NC		 1774 } else if (type == OP_UNDEF
1775#ifdef PERL_MAD
1776 || type == OP_STUB
1777#endif
1778 ) {
7766148a 1779 return o;
77ca0c92
LW		 1780 } else if (type == OP_RV2SV || /* "our" declaration */
1781 type == OP_RV2AV ||
1782 type == OP_RV2HV) { /* XXX does this let anything illegal in? */
1ce0b88c 1783 if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */
fab01b8e 1784 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
952306ac
RGS		 1785 OP_DESC(o),
1786 PL_in_my == KEY_our ? "our" : PL_in_my == KEY_state ? "state" : "my"));
1ce0b88c 1787 } else if (attrs) {
551405c4 1788 GV * const gv = cGVOPx_gv(cUNOPo->op_first);
1ce0b88c 1789 PL_in_my = FALSE;
5c284bb0 1790 PL_in_my_stash = NULL;
1ce0b88c
RGS		 1791 apply_attrs(GvSTASH(gv),
1792 (type == OP_RV2SV ? GvSV(gv) :
1793 type == OP_RV2AV ? (SV*)GvAV(gv) :
1794 type == OP_RV2HV ? (SV*)GvHV(gv) : (SV*)gv),
1795 attrs, FALSE);
1796 }
192587c2 1797 o->op_private |= OPpOUR_INTRO;
77ca0c92 1798 return o;
95f0a2f1
SB		 1799 }
1800 else if (type != OP_PADSV &&
93a17b20
LW		 1801 type != OP_PADAV &&
1802 type != OP_PADHV &&
1803 type != OP_PUSHMARK)
1804 {
eb64745e 1805 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
53e06cf0 1806 OP_DESC(o),
952306ac 1807 PL_in_my == KEY_our ? "our" : PL_in_my == KEY_state ? "state" : "my"));
11343788 1808 return o;
93a17b20 1809 }
09bef843
SB		 1810 else if (attrs && type != OP_PUSHMARK) {
1811 HV *stash;
09bef843 1812
eb64745e 1813 PL_in_my = FALSE;
5c284bb0 1814 PL_in_my_stash = NULL;
eb64745e 1815
09bef843 1816 /* check for C<my Dog $spot> when deciding package */
dd2155a4
DM		 1817 stash = PAD_COMPNAME_TYPE(o->op_targ);
1818 if (!stash)
09bef843 1819 stash = PL_curstash;
95f0a2f1 1820 apply_attrs_my(stash, o, attrs, imopsp);
09bef843 1821 }
11343788
MB		 1822 o->op_flags |= OPf_MOD;
1823 o->op_private |= OPpLVAL_INTRO;
952306ac
RGS		 1824 if (PL_in_my == KEY_state)
1825 o->op_private |= OPpPAD_STATE;
11343788 1826 return o;
93a17b20
LW		 1827}
1828
1829OP *
09bef843
SB		 1830Perl_my_attrs(pTHX_ OP *o, OP *attrs)
1831{
97aff369 1832 dVAR;
0bd48802 1833 OP *rops;
95f0a2f1
SB		 1834 int maybe_scalar = 0;
1835
d2be0de5 1836/* [perl #17376]: this appears to be premature, and results in code such as
c754c3d7 1837 C< our(%x); > executing in list mode rather than void mode */
d2be0de5 1838#if 0
09bef843
SB		 1839 if (o->op_flags & OPf_PARENS)
1840 list(o);
95f0a2f1
SB		 1841 else
1842 maybe_scalar = 1;
d2be0de5
YST		 1843#else
1844 maybe_scalar = 1;
1845#endif
09bef843
SB		 1846 if (attrs)
1847 SAVEFREEOP(attrs);
5f66b61c 1848 rops = NULL;
95f0a2f1
SB		 1849 o = my_kid(o, attrs, &rops);
1850 if (rops) {
1851 if (maybe_scalar && o->op_type == OP_PADSV) {
1852 o = scalar(append_list(OP_LIST, (LISTOP*)rops, (LISTOP*)o));
1853 o->op_private |= OPpLVAL_INTRO;
1854 }
1855 else
1856 o = append_list(OP_LIST, (LISTOP*)o, (LISTOP*)rops);
1857 }
eb64745e 1858 PL_in_my = FALSE;
5c284bb0 1859 PL_in_my_stash = NULL;
eb64745e 1860 return o;
09bef843
SB		 1861}
1862
1863OP *
1864Perl_my(pTHX_ OP *o)
1865{
5f66b61c 1866 return my_attrs(o, NULL);
09bef843
SB		 1867}
1868
1869OP *
864dbfa3 1870Perl_sawparens(pTHX_ OP *o)
79072805 1871{
96a5add6 1872 PERL_UNUSED_CONTEXT;
79072805
LW		 1873 if (o)
1874 o->op_flags |= OPf_PARENS;
1875 return o;
1876}
1877
1878OP *
864dbfa3 1879Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
79072805 1880{
11343788 1881 OP *o;
59f00321 1882 bool ismatchop = 0;
1496a290
AL		 1883 const OPCODE ltype = left->op_type;
1884 const OPCODE rtype = right->op_type;
79072805 1885
1496a290
AL		 1886 if ( (ltype == OP_RV2AV || ltype == OP_RV2HV || ltype == OP_PADAV
1887 || ltype == OP_PADHV) && ckWARN(WARN_MISC))
041457d9 1888 {
1496a290 1889 const char * const desc
666ea192
JH		 1890 = PL_op_desc[(rtype == OP_SUBST || rtype == OP_TRANS)
1891 ? (int)rtype : OP_MATCH];
1892 const char * const sample = ((ltype == OP_RV2AV || ltype == OP_PADAV)
1893 ? "@array" : "%hash");
9014280d 1894 Perl_warner(aTHX_ packWARN(WARN_MISC),
1c846c1f 1895 "Applying %s to %s will act on scalar(%s)",
599cee73 1896 desc, sample, sample);
2ae324a7 1897 }
1898
1496a290 1899 if (rtype == OP_CONST &&
5cc9e5c9
RH		 1900 cSVOPx(right)->op_private & OPpCONST_BARE &&
1901 cSVOPx(right)->op_private & OPpCONST_STRICT)
1902 {
1903 no_bareword_allowed(right);
1904 }
1905
1496a290
AL		 1906 ismatchop = rtype == OP_MATCH ||
1907 rtype == OP_SUBST ||
1908 rtype == OP_TRANS;
59f00321
RGS		 1909 if (ismatchop && right->op_private & OPpTARGET_MY) {
1910 right->op_targ = 0;
1911 right->op_private &= ~OPpTARGET_MY;
1912 }
1913 if (!(right->op_flags & OPf_STACKED) && ismatchop) {
1496a290
AL		 1914 OP *newleft;
1915
79072805 1916 right->op_flags |= OPf_STACKED;
1496a290
AL		 1917 if (rtype != OP_MATCH &&
1918 ! (rtype == OP_TRANS &&
6fbb66d6 1919 right->op_private & OPpTRANS_IDENTICAL))
1496a290
AL		 1920 newleft = mod(left, rtype);
1921 else
1922 newleft = left;
79072805 1923 if (right->op_type == OP_TRANS)
1496a290 1924 o = newBINOP(OP_NULL, OPf_STACKED, scalar(newleft), right);
79072805 1925 else
1496a290 1926 o = prepend_elem(rtype, scalar(newleft), right);
79072805 1927 if (type == OP_NOT)
11343788
MB		 1928 return newUNOP(OP_NOT, 0, scalar(o));
1929 return o;
79072805
LW		 1930 }
1931 else
1932 return bind_match(type, left,
131b3ad0 1933 pmruntime(newPMOP(OP_MATCH, 0), right, 0));
79072805
LW		 1934}
1935
1936OP *
864dbfa3 1937Perl_invert(pTHX_ OP *o)
79072805 1938{
11343788 1939 if (!o)
1d866c12 1940 return NULL;
11343788 1941 return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
79072805
LW		 1942}
1943
1944OP *
864dbfa3 1945Perl_scope(pTHX_ OP *o)
79072805 1946{
27da23d5 1947 dVAR;
79072805 1948 if (o) {
3280af22 1949 if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || PL_tainting) {
463ee0b2
LW		 1950 o = prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
1951 o->op_type = OP_LEAVE;
22c35a8c 1952 o->op_ppaddr = PL_ppaddr[OP_LEAVE];
463ee0b2 1953 }
fdb22418
HS		 1954 else if (o->op_type == OP_LINESEQ) {
1955 OP *kid;
1956 o->op_type = OP_SCOPE;
1957 o->op_ppaddr = PL_ppaddr[OP_SCOPE];
1958 kid = ((LISTOP*)o)->op_first;
59110972 1959 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
fdb22418 1960 op_null(kid);
59110972
RH		 1961
1962 /* The following deals with things like 'do {1 for 1}' */
1963 kid = kid->op_sibling;
1964 if (kid &&
1965 (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE))
1966 op_null(kid);
1967 }
463ee0b2 1968 }
fdb22418 1969 else
5f66b61c 1970 o = newLISTOP(OP_SCOPE, 0, o, NULL);
79072805
LW		 1971 }
1972 return o;
1973}
72dc9ed5 1974
a0d0e21e 1975int
864dbfa3 1976Perl_block_start(pTHX_ int full)
79072805 1977{
97aff369 1978 dVAR;
73d840c0 1979 const int retval = PL_savestack_ix;
dd2155a4 1980 pad_block_start(full);
b3ac6de7 1981 SAVEHINTS();
3280af22 1982 PL_hints &= ~HINT_BLOCK_SCOPE;
68da3b2f 1983 SAVECOMPILEWARNINGS();
72dc9ed5 1984 PL_compiling.cop_warnings = DUP_WARNINGS(PL_compiling.cop_warnings);
a0d0e21e
LW		 1985 return retval;
1986}
1987
1988OP*
864dbfa3 1989Perl_block_end(pTHX_ I32 floor, OP *seq)
a0d0e21e 1990{
97aff369 1991 dVAR;
6867be6d 1992 const int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
551405c4 1993 OP* const retval = scalarseq(seq);
e9818f4e 1994 LEAVE_SCOPE(floor);
623e6609 1995 CopHINTS_set(&PL_compiling, PL_hints);
a0d0e21e 1996 if (needblockscope)
3280af22 1997 PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
dd2155a4 1998 pad_leavemy();
a0d0e21e
LW		 1999 return retval;
2000}
2001
76e3520e 2002STATIC OP *
cea2e8a9 2003S_newDEFSVOP(pTHX)
54b9620d 2004{
97aff369 2005 dVAR;
9f7d9405 2006 const PADOFFSET offset = pad_findmy("$_");
00b1698f 2007 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
59f00321
RGS		 2008 return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
2009 }
2010 else {
551405c4 2011 OP * const o = newOP(OP_PADSV, 0);
59f00321
RGS		 2012 o->op_targ = offset;
2013 return o;
2014 }
54b9620d
MB		 2015}
2016
a0d0e21e 2017void
864dbfa3 2018Perl_newPROG(pTHX_ OP *o)
a0d0e21e 2019{
97aff369 2020 dVAR;
3280af22 2021 if (PL_in_eval) {
b295d113
TH		 2022 if (PL_eval_root)
2023 return;
faef0170
HS		 2024 PL_eval_root = newUNOP(OP_LEAVEEVAL,
2025 ((PL_in_eval & EVAL_KEEPERR)
2026 ? OPf_SPECIAL : 0), o);
3280af22 2027 PL_eval_start = linklist(PL_eval_root);
7934575e
GS		 2028 PL_eval_root->op_private |= OPpREFCOUNTED;
2029 OpREFCNT_set(PL_eval_root, 1);
3280af22 2030 PL_eval_root->op_next = 0;
a2efc822 2031 CALL_PEEP(PL_eval_start);
a0d0e21e
LW		 2032 }
2033 else {
6be89cf9
AE		 2034 if (o->op_type == OP_STUB) {
2035 PL_comppad_name = 0;
2036 PL_compcv = 0;
2a4f803a 2037 FreeOp(o);
a0d0e21e 2038 return;
6be89cf9 2039 }
3280af22
NIS		 2040 PL_main_root = scope(sawparens(scalarvoid(o)));
2041 PL_curcop = &PL_compiling;
2042 PL_main_start = LINKLIST(PL_main_root);
7934575e
GS		 2043 PL_main_root->op_private |= OPpREFCOUNTED;
2044 OpREFCNT_set(PL_main_root, 1);
3280af22 2045 PL_main_root->op_next = 0;
a2efc822 2046 CALL_PEEP(PL_main_start);
3280af22 2047 PL_compcv = 0;
3841441e 2048
4fdae800 2049 /* Register with debugger */
84902520 2050 if (PERLDB_INTER) {
551405c4 2051 CV * const cv = get_cv("DB::postponed", FALSE);
3841441e
CS		 2052 if (cv) {
2053 dSP;
924508f0 2054 PUSHMARK(SP);
cc49e20b 2055 XPUSHs((SV*)CopFILEGV(&PL_compiling));
3841441e 2056 PUTBACK;
864dbfa3 2057 call_sv((SV*)cv, G_DISCARD);
3841441e
CS		 2058 }
2059 }
79072805 2060 }
79072805
LW		 2061}
2062
2063OP *
864dbfa3 2064Perl_localize(pTHX_ OP *o, I32 lex)
79072805 2065{
97aff369 2066 dVAR;
79072805 2067 if (o->op_flags & OPf_PARENS)
d2be0de5
YST		 2068/* [perl #17376]: this appears to be premature, and results in code such as
2069 C< our(%x); > executing in list mode rather than void mode */
2070#if 0
79072805 2071 list(o);
d2be0de5 2072#else
6f207bd3 2073 NOOP;
d2be0de5 2074#endif
8990e307 2075 else {
041457d9
DM		 2076 if ( PL_bufptr > PL_oldbufptr && PL_bufptr[-1] == ','
2077 && ckWARN(WARN_PARENTHESIS))
64420d0d
JH		 2078 {
2079 char *s = PL_bufptr;
bac662ee 2080 bool sigil = FALSE;
64420d0d 2081
8473848f 2082 /* some heuristics to detect a potential error */
bac662ee 2083 while (*s && (strchr(", \t\n", *s)))
64420d0d 2084 s++;
8473848f 2085
bac662ee
TS		 2086 while (1) {
2087 if (*s && strchr("@$%*", *s) && *++s
2088 && (isALNUM(*s) || UTF8_IS_CONTINUED(*s))) {
2089 s++;
2090 sigil = TRUE;
2091 while (*s && (isALNUM(*s) || UTF8_IS_CONTINUED(*s)))
2092 s++;
2093 while (*s && (strchr(", \t\n", *s)))
2094 s++;
2095 }
2096 else
2097 break;
2098 }
2099 if (sigil && (*s == ';' || *s == '=')) {
2100 Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS),
8473848f 2101 "Parentheses missing around \"%s\" list",
952306ac 2102 lex ? (PL_in_my == KEY_our ? "our" : PL_in_my == KEY_state ? "state" : "my")
8473848f
RGS		 2103 : "local");
2104 }
8990e307
LW		 2105 }
2106 }
93a17b20 2107 if (lex)
eb64745e 2108 o = my(o);
93a17b20 2109 else
eb64745e
GS		 2110 o = mod(o, OP_NULL); /* a bit kludgey */
2111 PL_in_my = FALSE;
5c284bb0 2112 PL_in_my_stash = NULL;
eb64745e 2113 return o;
79072805
LW		 2114}
2115
2116OP *
864dbfa3 2117Perl_jmaybe(pTHX_ OP *o)
79072805
LW		 2118{
2119 if (o->op_type == OP_LIST) {
fafc274c 2120 OP * const o2
d4c19fe8 2121 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpvs(";", GV_ADD|GV_NOTQUAL, SVt_PV)));
554b3eca 2122 o = convert(OP_JOIN, 0, prepend_elem(OP_LIST, o2, o));
79072805
LW		 2123 }
2124 return o;
2125}
2126
2127OP *
864dbfa3 2128Perl_fold_constants(pTHX_ register OP *o)
79072805 2129{
27da23d5 2130 dVAR;
79072805 2131 register OP *curop;
eb8433b7 2132 OP *newop;
8ea43dc8 2133 VOL I32 type = o->op_type;
e3cbe32f 2134 SV * VOL sv = NULL;
b7f7fd0b
NC		 2135 int ret = 0;
2136 I32 oldscope;
2137 OP *old_next;
5f2d9966
DM		 2138 SV * const oldwarnhook = PL_warnhook;
2139 SV * const olddiehook = PL_diehook;
b7f7fd0b 2140 dJMPENV;
79072805 2141
22c35a8c 2142 if (PL_opargs[type] & OA_RETSCALAR)
79072805 2143 scalar(o);
b162f9ea 2144 if (PL_opargs[type] & OA_TARGET && !o->op_targ)
ed6116ce 2145 o->op_targ = pad_alloc(type, SVs_PADTMP);
79072805 2146
eac055e9
GS		 2147 /* integerize op, unless it happens to be C<-foo>.
2148 * XXX should pp_i_negate() do magic string negation instead? */
2149 if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER)
2150 && !(type == OP_NEGATE && cUNOPo->op_first->op_type == OP_CONST
2151 && (cUNOPo->op_first->op_private & OPpCONST_BARE)))
2152 {
22c35a8c 2153 o->op_ppaddr = PL_ppaddr[type = ++(o->op_type)];
eac055e9 2154 }
85e6fe83 2155
22c35a8c 2156 if (!(PL_opargs[type] & OA_FOLDCONST))
79072805
LW		 2157 goto nope;
2158
de939608 2159 switch (type) {
7a52d87a
GS		 2160 case OP_NEGATE:
2161 /* XXX might want a ck_negate() for this */
2162 cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
2163 break;
de939608
CS		 2164 case OP_UCFIRST:
2165 case OP_LCFIRST:
2166 case OP_UC:
2167 case OP_LC:
69dcf70c
MB		 2168 case OP_SLT:
2169 case OP_SGT:
2170 case OP_SLE:
2171 case OP_SGE:
2172 case OP_SCMP:
2de3dbcc
JH		 2173 /* XXX what about the numeric ops? */
2174 if (PL_hints & HINT_LOCALE)
de939608
CS		 2175 goto nope;
2176 }
2177
3280af22 2178 if (PL_error_count)
a0d0e21e
LW		 2179 goto nope; /* Don't try to run w/ errors */
2180
79072805 2181 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
1496a290
AL		 2182 const OPCODE type = curop->op_type;
2183 if ((type != OP_CONST || (curop->op_private & OPpCONST_BARE)) &&
2184 type != OP_LIST &&
2185 type != OP_SCALAR &&
2186 type != OP_NULL &&
2187 type != OP_PUSHMARK)
7a52d87a 2188 {
79072805
LW		 2189 goto nope;
2190 }
2191 }
2192
2193 curop = LINKLIST(o);
b7f7fd0b 2194 old_next = o->op_next;
79072805 2195 o->op_next = 0;
533c011a 2196 PL_op = curop;
b7f7fd0b
NC		 2197
2198 oldscope = PL_scopestack_ix;
edb2152a 2199 create_eval_scope(G_FAKINGEVAL);
b7f7fd0b 2200
5f2d9966
DM		 2201 PL_warnhook = PERL_WARNHOOK_FATAL;
2202 PL_diehook = NULL;
b7f7fd0b
NC		 2203 JMPENV_PUSH(ret);
2204
2205 switch (ret) {
2206 case 0:
2207 CALLRUNOPS(aTHX);
2208 sv = *(PL_stack_sp--);
2209 if (o->op_targ && sv == PAD_SV(o->op_targ)) /* grab pad temp? */
2210 pad_swipe(o->op_targ, FALSE);
2211 else if (SvTEMP(sv)) { /* grab mortal temp? */
2212 SvREFCNT_inc_simple_void(sv);
2213 SvTEMP_off(sv);
2214 }
2215 break;
2216 case 3:
2217 /* Something tried to die. Abandon constant folding. */
2218 /* Pretend the error never happened. */
2219 sv_setpvn(ERRSV,"",0);
2220 o->op_next = old_next;
2221 break;
2222 default:
2223 JMPENV_POP;
5f2d9966
DM		 2224 /* Don't expect 1 (setjmp failed) or 2 (something called my_exit) */
2225 PL_warnhook = oldwarnhook;
2226 PL_diehook = olddiehook;
2227 /* XXX note that this croak may fail as we've already blown away
2228 * the stack - eg any nested evals */
b7f7fd0b
NC		 2229 Perl_croak(aTHX_ "panic: fold_constants JMPENV_PUSH returned %d", ret);
2230 }
b7f7fd0b 2231 JMPENV_POP;
5f2d9966
DM		 2232 PL_warnhook = oldwarnhook;
2233 PL_diehook = olddiehook;
edb2152a
NC		 2234
2235 if (PL_scopestack_ix > oldscope)
2236 delete_eval_scope();
eb8433b7 2237
b7f7fd0b
NC		 2238 if (ret)
2239 goto nope;
2240
eb8433b7 2241#ifndef PERL_MAD
79072805 2242 op_free(o);
eb8433b7 2243#endif
de5e01c2 2244 assert(sv);
79072805 2245 if (type == OP_RV2GV)
eb8433b7
NC		 2246 newop = newGVOP(OP_GV, 0, (GV*)sv);
2247 else
670f1322 2248 newop = newSVOP(OP_CONST, 0, (SV*)sv);
eb8433b7
NC		 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;
78c72037
NC		 2273 assert (!(curop->op_flags & OPf_SPECIAL));
2274 assert(curop->op_type == OP_RANGE);
cea2e8a9 2275 pp_anonlist();
3280af22 2276 PL_tmps_floor = oldtmps_floor;
79072805
LW		 2277
2278 o->op_type = OP_RV2AV;
22c35a8c 2279 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
fb53bbb2
SG		 2280 o->op_flags &= ~OPf_REF; /* treat \(1..2) like an ordinary list */
2281 o->op_flags |= OPf_PARENS; /* and flatten \(1..2,3) */
2814eb74 2282 o->op_opt = 0; /* needs to be revisited in peep() */
79072805 2283 curop = ((UNOP*)o)->op_first;
b37c2d43 2284 ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, SvREFCNT_inc_NN(*PL_stack_sp--));
eb8433b7
NC		 2285#ifdef PERL_MAD
2286 op_getmad(curop,o,'O');
2287#else
79072805 2288 op_free(curop);
eb8433b7 2289#endif
79072805
LW		 2290 linklist(o);
2291 return list(o);
2292}
2293
2294OP *
864dbfa3 2295Perl_convert(pTHX_ I32 type, I32 flags, OP *o)
79072805 2296{
27da23d5 2297 dVAR;
11343788 2298 if (!o || o->op_type != OP_LIST)
5f66b61c 2299 o = newLISTOP(OP_LIST, 0, o, NULL);
748a9306 2300 else
5dc0d613 2301 o->op_flags &= ~OPf_WANT;
79072805 2302
22c35a8c 2303 if (!(PL_opargs[type] & OA_MARK))
93c66552 2304 op_null(cLISTOPo->op_first);
8990e307 2305
eb160463 2306 o->op_type = (OPCODE)type;
22c35a8c 2307 o->op_ppaddr = PL_ppaddr[type];
11343788 2308 o->op_flags |= flags;
79072805 2309
11343788 2310 o = CHECKOP(type, o);
fe2774ed 2311 if (o->op_type != (unsigned)type)
11343788 2312 return o;
79072805 2313
11343788 2314 return fold_constants(o);
79072805
LW		 2315}
2316
2317/* List constructors */
2318
2319OP *
864dbfa3 2320Perl_append_elem(pTHX_ I32 type, OP *first, OP *last)
79072805
LW		 2321{
2322 if (!first)
2323 return last;
8990e307
LW		 2324
2325 if (!last)
79072805 2326 return first;
8990e307 2327
fe2774ed 2328 if (first->op_type != (unsigned)type
155aba94
GS		 2329 || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
2330 {
2331 return newLISTOP(type, 0, first, last);
2332 }
79072805 2333
a0d0e21e
LW		 2334 if (first->op_flags & OPf_KIDS)
2335 ((LISTOP*)first)->op_last->op_sibling = last;
2336 else {
2337 first->op_flags |= OPf_KIDS;
2338 ((LISTOP*)first)->op_first = last;
2339 }
2340 ((LISTOP*)first)->op_last = last;
a0d0e21e 2341 return first;
79072805
LW		 2342}
2343
2344OP *
864dbfa3 2345Perl_append_list(pTHX_ I32 type, LISTOP *first, LISTOP *last)
79072805
LW		 2346{
2347 if (!first)
2348 return (OP*)last;
8990e307
LW		 2349
2350 if (!last)
79072805 2351 return (OP*)first;
8990e307 2352
fe2774ed 2353 if (first->op_type != (unsigned)type)
79072805 2354 return prepend_elem(type, (OP*)first, (OP*)last);
8990e307 2355
fe2774ed 2356 if (last->op_type != (unsigned)type)
79072805
LW		 2357 return append_elem(type, (OP*)first, (OP*)last);
2358
2359 first->op_last->op_sibling = last->op_first;
2360 first->op_last = last->op_last;
117dada2 2361 first->op_flags |= (last->op_flags & OPf_KIDS);
1c846c1f 2362
eb8433b7
NC		 2363#ifdef PERL_MAD
2364 if (last->op_first && first->op_madprop) {
2365 MADPROP *mp = last->op_first->op_madprop;
2366 if (mp) {
2367 while (mp->mad_next)
2368 mp = mp->mad_next;
2369 mp->mad_next = first->op_madprop;
2370 }
2371 else {
2372 last->op_first->op_madprop = first->op_madprop;
2373 }
2374 }
2375 first->op_madprop = last->op_madprop;
2376 last->op_madprop = 0;
2377#endif
2378
238a4c30
NIS		 2379 FreeOp(last);
2380
79072805
LW		 2381 return (OP*)first;
2382}
2383
2384OP *
864dbfa3 2385Perl_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
79072805
LW		 2386{
2387 if (!first)
2388 return last;
8990e307
LW		 2389
2390 if (!last)
79072805 2391 return first;
8990e307 2392
fe2774ed 2393 if (last->op_type == (unsigned)type) {
8990e307
LW		 2394 if (type == OP_LIST) { /* already a PUSHMARK there */
2395 first->op_sibling = ((LISTOP*)last)->op_first->op_sibling;
2396 ((LISTOP*)last)->op_first->op_sibling = first;
36a5d4ba
DC		 2397 if (!(first->op_flags & OPf_PARENS))
2398 last->op_flags &= ~OPf_PARENS;
8990e307
LW		 2399 }
2400 else {
2401 if (!(last->op_flags & OPf_KIDS)) {
2402 ((LISTOP*)last)->op_last = first;
2403 last->op_flags |= OPf_KIDS;
2404 }
2405 first->op_sibling = ((LISTOP*)last)->op_first;
2406 ((LISTOP*)last)->op_first = first;
79072805 2407 }
117dada2 2408 last->op_flags |= OPf_KIDS;
79072805
LW		 2409 return last;
2410 }
2411
2412 return newLISTOP(type, 0, first, last);
2413}
2414
2415/* Constructors */
2416
eb8433b7
NC		 2417#ifdef PERL_MAD
2418
2419TOKEN *
2420Perl_newTOKEN(pTHX_ I32 optype, YYSTYPE lval, MADPROP* madprop)
2421{
2422 TOKEN *tk;
99129197 2423 Newxz(tk, 1, TOKEN);
eb8433b7
NC		 2424 tk->tk_type = (OPCODE)optype;
2425 tk->tk_type = 12345;
2426 tk->tk_lval = lval;
2427 tk->tk_mad = madprop;
2428 return tk;
2429}
2430
2431void
2432Perl_token_free(pTHX_ TOKEN* tk)
2433{
2434 if (tk->tk_type != 12345)
2435 return;
2436 mad_free(tk->tk_mad);
2437 Safefree(tk);
2438}
2439
2440void
2441Perl_token_getmad(pTHX_ TOKEN* tk, OP* o, char slot)
2442{
2443 MADPROP* mp;
2444 MADPROP* tm;
2445 if (tk->tk_type != 12345) {
2446 Perl_warner(aTHX_ packWARN(WARN_MISC),
2447 "Invalid TOKEN object ignored");
2448 return;
2449 }
2450 tm = tk->tk_mad;
2451 if (!tm)
2452 return;
2453
2454 /* faked up qw list? */
2455 if (slot == '(' &&
2456 tm->mad_type == MAD_SV &&
2457 SvPVX((SV*)tm->mad_val)[0] == 'q')
2458 slot = 'x';
2459
2460 if (o) {
2461 mp = o->op_madprop;
2462 if (mp) {
2463 for (;;) {
2464 /* pretend constant fold didn't happen? */
2465 if (mp->mad_key == 'f' &&
2466 (o->op_type == OP_CONST ||
2467 o->op_type == OP_GV) )
2468 {
2469 token_getmad(tk,(OP*)mp->mad_val,slot);
2470 return;
2471 }
2472 if (!mp->mad_next)
2473 break;
2474 mp = mp->mad_next;
2475 }
2476 mp->mad_next = tm;
2477 mp = mp->mad_next;
2478 }
2479 else {
2480 o->op_madprop = tm;
2481 mp = o->op_madprop;
2482 }
2483 if (mp->mad_key == 'X')
2484 mp->mad_key = slot; /* just change the first one */
2485
2486 tk->tk_mad = 0;
2487 }
2488 else
2489 mad_free(tm);
2490 Safefree(tk);
2491}
2492
2493void
2494Perl_op_getmad_weak(pTHX_ OP* from, OP* o, char slot)
2495{
2496 MADPROP* mp;
2497 if (!from)
2498 return;
2499 if (o) {
2500 mp = o->op_madprop;
2501 if (mp) {
2502 for (;;) {
2503 /* pretend constant fold didn't happen? */
2504 if (mp->mad_key == 'f' &&
2505 (o->op_type == OP_CONST ||
2506 o->op_type == OP_GV) )
2507 {
2508 op_getmad(from,(OP*)mp->mad_val,slot);
2509 return;
2510 }
2511 if (!mp->mad_next)
2512 break;
2513 mp = mp->mad_next;
2514 }
2515 mp->mad_next = newMADPROP(slot,MAD_OP,from,0);
2516 }
2517 else {
2518 o->op_madprop = newMADPROP(slot,MAD_OP,from,0);
2519 }
2520 }
2521}
2522
2523void
2524Perl_op_getmad(pTHX_ OP* from, OP* o, char slot)
2525{
2526 MADPROP* mp;
2527 if (!from)
2528 return;
2529 if (o) {
2530 mp = o->op_madprop;
2531 if (mp) {
2532 for (;;) {
2533 /* pretend constant fold didn't happen? */
2534 if (mp->mad_key == 'f' &&
2535 (o->op_type == OP_CONST ||
2536 o->op_type == OP_GV) )
2537 {
2538 op_getmad(from,(OP*)mp->mad_val,slot);
2539 return;
2540 }
2541 if (!mp->mad_next)
2542 break;
2543 mp = mp->mad_next;
2544 }
2545 mp->mad_next = newMADPROP(slot,MAD_OP,from,1);
2546 }
2547 else {
2548 o->op_madprop = newMADPROP(slot,MAD_OP,from,1);
2549 }
2550 }
2551 else {
99129197
NC		 2552 PerlIO_printf(PerlIO_stderr(),
2553 "DESTROYING op = %0"UVxf"\n", PTR2UV(from));
eb8433b7
NC		 2554 op_free(from);
2555 }
2556}
2557
2558void
2559Perl_prepend_madprops(pTHX_ MADPROP* mp, OP* o, char slot)
2560{
2561 MADPROP* tm;
2562 if (!mp || !o)
2563 return;
2564 if (slot)
2565 mp->mad_key = slot;
2566 tm = o->op_madprop;
2567 o->op_madprop = mp;
2568 for (;;) {
2569 if (!mp->mad_next)
2570 break;
2571 mp = mp->mad_next;
2572 }
2573 mp->mad_next = tm;
2574}
2575
2576void
2577Perl_append_madprops(pTHX_ MADPROP* tm, OP* o, char slot)
2578{
2579 if (!o)
2580 return;
2581 addmad(tm, &(o->op_madprop), slot);
2582}
2583
2584void
2585Perl_addmad(pTHX_ MADPROP* tm, MADPROP** root, char slot)
2586{
2587 MADPROP* mp;
2588 if (!tm || !root)
2589 return;
2590 if (slot)
2591 tm->mad_key = slot;
2592 mp = *root;
2593 if (!mp) {
2594 *root = tm;
2595 return;
2596 }
2597 for (;;) {
2598 if (!mp->mad_next)
2599 break;
2600 mp = mp->mad_next;
2601 }
2602 mp->mad_next = tm;
2603}
2604
2605MADPROP *
2606Perl_newMADsv(pTHX_ char key, SV* sv)
2607{
2608 return newMADPROP(key, MAD_SV, sv, 0);
2609}
2610
2611MADPROP *
2612Perl_newMADPROP(pTHX_ char key, char type, void* val, I32 vlen)
2613{
2614 MADPROP *mp;
99129197 2615 Newxz(mp, 1, MADPROP);
eb8433b7
NC		 2616 mp->mad_next = 0;
2617 mp->mad_key = key;
2618 mp->mad_vlen = vlen;
2619 mp->mad_type = type;
2620 mp->mad_val = val;
2621/* PerlIO_printf(PerlIO_stderr(), "NEW mp = %0x\n", mp); */
2622 return mp;
2623}
2624
2625void
2626Perl_mad_free(pTHX_ MADPROP* mp)
2627{
2628/* PerlIO_printf(PerlIO_stderr(), "FREE mp = %0x\n", mp); */
2629 if (!mp)
2630 return;
2631 if (mp->mad_next)
2632 mad_free(mp->mad_next);
2633/* if (PL_lex_state != LEX_NOTPARSING && mp->mad_vlen)
2634 PerlIO_printf(PerlIO_stderr(), "DESTROYING '%c'=<%s>\n", mp->mad_key & 255, mp->mad_val); */
2635 switch (mp->mad_type) {
2636 case MAD_NULL:
2637 break;
2638 case MAD_PV:
2639 Safefree((char*)mp->mad_val);
2640 break;
2641 case MAD_OP:
2642 if (mp->mad_vlen) /* vlen holds "strong/weak" boolean */
2643 op_free((OP*)mp->mad_val);
2644 break;
2645 case MAD_SV:
2646 sv_free((SV*)mp->mad_val);
2647 break;
2648 default:
2649 PerlIO_printf(PerlIO_stderr(), "Unrecognized mad\n");
2650 break;
2651 }
2652 Safefree(mp);
2653}
2654
2655#endif
2656
79072805 2657OP *
864dbfa3 2658Perl_newNULLLIST(pTHX)
79072805 2659{
8990e307
LW		 2660 return newOP(OP_STUB, 0);
2661}
2662
2663OP *
864dbfa3 2664Perl_force_list(pTHX_ OP *o)
8990e307 2665{
11343788 2666 if (!o || o->op_type != OP_LIST)
5f66b61c 2667 o = newLISTOP(OP_LIST, 0, o, NULL);
93c66552 2668 op_null(o);
11343788 2669 return o;
79072805
LW		 2670}
2671
2672OP *
864dbfa3 2673Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
79072805 2674{
27da23d5 2675 dVAR;
79072805
LW		 2676 LISTOP *listop;
2677
b7dc083c 2678 NewOp(1101, listop, 1, LISTOP);
79072805 2679
eb160463 2680 listop->op_type = (OPCODE)type;
22c35a8c 2681 listop->op_ppaddr = PL_ppaddr[type];
117dada2
SM		 2682 if (first || last)
2683 flags |= OPf_KIDS;
eb160463 2684 listop->op_flags = (U8)flags;
79072805
LW		 2685
2686 if (!last && first)
2687 last = first;
2688 else if (!first && last)
2689 first = last;
8990e307
LW		 2690 else if (first)
2691 first->op_sibling = last;
79072805
LW		 2692 listop->op_first = first;
2693 listop->op_last = last;
8990e307 2694 if (type == OP_LIST) {
551405c4 2695 OP* const pushop = newOP(OP_PUSHMARK, 0);
8990e307
LW		 2696 pushop->op_sibling = first;
2697 listop->op_first = pushop;
2698 listop->op_flags |= OPf_KIDS;
2699 if (!last)
2700 listop->op_last = pushop;
2701 }
79072805 2702
463d09e6 2703 return CHECKOP(type, listop);
79072805
LW		 2704}
2705
2706OP *
864dbfa3 2707Perl_newOP(pTHX_ I32 type, I32 flags)
79072805 2708{
27da23d5 2709 dVAR;
11343788 2710 OP *o;
b7dc083c 2711 NewOp(1101, o, 1, OP);
eb160463 2712 o->op_type = (OPCODE)type;
22c35a8c 2713 o->op_ppaddr = PL_ppaddr[type];
eb160463 2714 o->op_flags = (U8)flags;
79072805 2715
11343788 2716 o->op_next = o;
eb160463 2717 o->op_private = (U8)(0 | (flags >> 8));
22c35a8c 2718 if (PL_opargs[type] & OA_RETSCALAR)
11343788 2719 scalar(o);
22c35a8c 2720 if (PL_opargs[type] & OA_TARGET)
11343788
MB		 2721 o->op_targ = pad_alloc(type, SVs_PADTMP);
2722 return CHECKOP(type, o);
79072805
LW		 2723}
2724
2725OP *
864dbfa3 2726Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
79072805 2727{
27da23d5 2728 dVAR;
79072805
LW		 2729 UNOP *unop;
2730
93a17b20 2731 if (!first)
aeea060c 2732 first = newOP(OP_STUB, 0);
22c35a8c 2733 if (PL_opargs[type] & OA_MARK)
8990e307 2734 first = force_list(first);
93a17b20 2735
b7dc083c 2736 NewOp(1101, unop, 1, UNOP);
eb160463 2737 unop->op_type = (OPCODE)type;
22c35a8c 2738 unop->op_ppaddr = PL_ppaddr[type];
79072805 2739 unop->op_first = first;
585ec06d 2740 unop->op_flags = (U8)(flags | OPf_KIDS);
eb160463 2741 unop->op_private = (U8)(1 | (flags >> 8));
e50aee73 2742 unop = (UNOP*) CHECKOP(type, unop);
79072805
LW		 2743 if (unop->op_next)
2744 return (OP*)unop;
2745
a0d0e21e 2746 return fold_constants((OP *) unop);
79072805
LW		 2747}
2748
2749OP *
864dbfa3 2750Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
79072805 2751{
27da23d5 2752 dVAR;
79072805 2753 BINOP *binop;
b7dc083c 2754 NewOp(1101, binop, 1, BINOP);
79072805
LW		 2755
2756 if (!first)
2757 first = newOP(OP_NULL, 0);
2758
eb160463 2759 binop->op_type = (OPCODE)type;
22c35a8c 2760 binop->op_ppaddr = PL_ppaddr[type];
79072805 2761 binop->op_first = first;
585ec06d 2762 binop->op_flags = (U8)(flags | OPf_KIDS);
79072805
LW		 2763 if (!last) {
2764 last = first;
eb160463 2765 binop->op_private = (U8)(1 | (flags >> 8));
79072805
LW		 2766 }
2767 else {
eb160463 2768 binop->op_private = (U8)(2 | (flags >> 8));
79072805
LW		 2769 first->op_sibling = last;
2770 }
2771
e50aee73 2772 binop = (BINOP*)CHECKOP(type, binop);
eb160463 2773 if (binop->op_next || binop->op_type != (OPCODE)type)
79072805
LW		 2774 return (OP*)binop;
2775
7284ab6f 2776 binop->op_last = binop->op_first->op_sibling;
79072805 2777
a0d0e21e 2778 return fold_constants((OP *)binop);
79072805
LW		 2779}
2780
5f66b61c
AL		 2781static int uvcompare(const void *a, const void *b)
2782 __attribute__nonnull__(1)
2783 __attribute__nonnull__(2)
2784 __attribute__pure__;
abb2c242 2785static int uvcompare(const void *a, const void *b)
2b9d42f0 2786{
e1ec3a88 2787 if (*((const UV *)a) < (*(const UV *)b))
2b9d42f0 2788 return -1;
e1ec3a88 2789 if (*((const UV *)a) > (*(const UV *)b))
2b9d42f0 2790 return 1;
e1ec3a88 2791 if (*((const UV *)a+1) < (*(const UV *)b+1))
2b9d42f0 2792 return -1;
e1ec3a88 2793 if (*((const UV *)a+1) > (*(const UV *)b+1))
2b9d42f0 2794 return 1;
a0ed51b3
LW		 2795 return 0;
2796}
2797
79072805 2798OP *
864dbfa3 2799Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
79072805 2800{
97aff369 2801 dVAR;
2d03de9c
AL		 2802 SV * const tstr = ((SVOP*)expr)->op_sv;
2803 SV * const rstr = ((SVOP*)repl)->op_sv;
463ee0b2
LW		 2804 STRLEN tlen;
2805 STRLEN rlen;
5c144d81
NC		 2806 const U8 *t = (U8*)SvPV_const(tstr, tlen);
2807 const U8 *r = (U8*)SvPV_const(rstr, rlen);
79072805
LW		 2808 register I32 i;
2809 register I32 j;
9b877dbb 2810 I32 grows = 0;
79072805
LW		 2811 register short *tbl;
2812
551405c4
AL		 2813 const I32 complement = o->op_private & OPpTRANS_COMPLEMENT;
2814 const I32 squash = o->op_private & OPpTRANS_SQUASH;
2815 I32 del = o->op_private & OPpTRANS_DELETE;
800b4dc4 2816 PL_hints |= HINT_BLOCK_SCOPE;
1c846c1f 2817
036b4402
GS		 2818 if (SvUTF8(tstr))
2819 o->op_private |= OPpTRANS_FROM_UTF;
1c846c1f
NIS		 2820
2821 if (SvUTF8(rstr))
036b4402 2822 o->op_private |= OPpTRANS_TO_UTF;
79072805 2823
a0ed51b3 2824 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
396482e1 2825 SV* const listsv = newSVpvs("# comment\n");
c445ea15 2826 SV* transv = NULL;
5c144d81
NC		 2827 const U8* tend = t + tlen;
2828 const U8* rend = r + rlen;
ba210ebe 2829 STRLEN ulen;
84c133a0
RB		 2830 UV tfirst = 1;
2831 UV tlast = 0;
2832 IV tdiff;
2833 UV rfirst = 1;
2834 UV rlast = 0;
2835 IV rdiff;
2836 IV diff;
a0ed51b3
LW		 2837 I32 none = 0;
2838 U32 max = 0;
2839 I32 bits;
a0ed51b3 2840 I32 havefinal = 0;
9c5ffd7c 2841 U32 final = 0;
551405c4
AL		 2842 const I32 from_utf = o->op_private & OPpTRANS_FROM_UTF;
2843 const I32 to_utf = o->op_private & OPpTRANS_TO_UTF;
bf4a1e57
JH		 2844 U8* tsave = NULL;
2845 U8* rsave = NULL;
9f7f3913 2846 const U32 flags = UTF8_ALLOW_DEFAULT;
bf4a1e57
JH		 2847
2848 if (!from_utf) {
2849 STRLEN len = tlen;
5c144d81 2850 t = tsave = bytes_to_utf8(t, &len);
bf4a1e57
JH		 2851 tend = t + len;
2852 }
2853 if (!to_utf && rlen) {
2854 STRLEN len = rlen;
5c144d81 2855 r = rsave = bytes_to_utf8(r, &len);
bf4a1e57
JH		 2856 rend = r + len;
2857 }
a0ed51b3 2858
2b9d42f0
NIS		 2859/* There are several snags with this code on EBCDIC:
2860 1. 0xFF is a legal UTF-EBCDIC byte (there are no illegal bytes).
2861 2. scan_const() in toke.c has encoded chars in native encoding which makes
2862 ranges at least in EBCDIC 0..255 range the bottom odd.
2863*/
2864
a0ed51b3 2865 if (complement) {
89ebb4a3 2866 U8 tmpbuf[UTF8_MAXBYTES+1];
2b9d42f0 2867 UV *cp;
a0ed51b3 2868 UV nextmin = 0;
a02a5408 2869 Newx(cp, 2*tlen, UV);
a0ed51b3 2870 i = 0;
396482e1 2871 transv = newSVpvs("");
a0ed51b3 2872 while (t < tend) {
9f7f3913 2873 cp[2*i] = utf8n_to_uvuni(t, tend-t, &ulen, flags);
2b9d42f0
NIS		 2874 t += ulen;
2875 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) {
a0ed51b3 2876 t++;
9f7f3913 2877 cp[2*i+1] = utf8n_to_uvuni(t, tend-t, &ulen, flags);
2b9d42f0 2878 t += ulen;
a0ed51b3 2879 }
2b9d42f0
NIS		 2880 else {
2881 cp[2*i+1] = cp[2*i];
2882 }
2883 i++;
a0ed51b3 2884 }
2b9d42f0 2885 qsort(cp, i, 2*sizeof(UV), uvcompare);
a0ed51b3 2886 for (j = 0; j < i; j++) {
2b9d42f0 2887 UV val = cp[2*j];
a0ed51b3
LW		 2888 diff = val - nextmin;
2889 if (diff > 0) {
9041c2e3 2890 t = uvuni_to_utf8(tmpbuf,nextmin);
dfe13c55 2891 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
a0ed51b3 2892 if (diff > 1) {
2b9d42f0 2893 U8 range_mark = UTF_TO_NATIVE(0xff);
9041c2e3 2894 t = uvuni_to_utf8(tmpbuf, val - 1);
2b9d42f0 2895 sv_catpvn(transv, (char *)&range_mark, 1);
dfe13c55 2896 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
a0ed51b3
LW		 2897 }
2898 }
2b9d42f0 2899 val = cp[2*j+1];
a0ed51b3
LW		 2900 if (val >= nextmin)
2901 nextmin = val + 1;
2902 }
9041c2e3 2903 t = uvuni_to_utf8(tmpbuf,nextmin);
dfe13c55 2904 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2b9d42f0
NIS		 2905 {
2906 U8 range_mark = UTF_TO_NATIVE(0xff);
2907 sv_catpvn(transv, (char *)&range_mark, 1);
2908 }
b851fbc1
JH		 2909 t = uvuni_to_utf8_flags(tmpbuf, 0x7fffffff,
2910 UNICODE_ALLOW_SUPER);
dfe13c55 2911 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
93524f2b 2912 t = (const U8*)SvPVX_const(transv);
a0ed51b3
LW		 2913 tlen = SvCUR(transv);
2914 tend = t + tlen;
455d824a 2915 Safefree(cp);
a0ed51b3
LW		 2916 }
2917 else if (!rlen && !del) {
2918 r = t; rlen = tlen; rend = tend;
4757a243
LW		 2919 }
2920 if (!squash) {
05d340b8 2921 if ((!rlen && !del) || t == r ||
12ae5dfc 2922 (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
01ec43d0 2923 {
4757a243 2924 o->op_private |= OPpTRANS_IDENTICAL;
01ec43d0 2925 }
a0ed51b3
LW		 2926 }
2927
2928 while (t < tend || tfirst <= tlast) {
2929 /* see if we need more "t" chars */
2930 if (tfirst > tlast) {
9f7f3913 2931 tfirst = (I32)utf8n_to_uvuni(t, tend - t, &ulen, flags);
a0ed51b3 2932 t += ulen;
2b9d42f0 2933 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) { /* illegal utf8 val indicates range */
ba210ebe 2934 t++;
9f7f3913 2935 tlast = (I32)utf8n_to_uvuni(t, tend - t, &ulen, flags);
a0ed51b3
LW		 2936 t += ulen;
2937 }
2938 else
2939 tlast = tfirst;
2940 }
2941
2942 /* now see if we need more "r" chars */
2943 if (rfirst > rlast) {
2944 if (r < rend) {
9f7f3913 2945 rfirst = (I32)utf8n_to_uvuni(r, rend - r, &ulen, flags);
a0ed51b3 2946 r += ulen;
2b9d42f0 2947 if (r < rend && NATIVE_TO_UTF(*r) == 0xff) { /* illegal utf8 val indicates range */
ba210ebe 2948 r++;
9f7f3913 2949 rlast = (I32)utf8n_to_uvuni(r, rend - r, &ulen, flags);
a0ed51b3
LW		 2950 r += ulen;
2951 }
2952 else
2953 rlast = rfirst;
2954 }
2955 else {
2956 if (!havefinal++)
2957 final = rlast;
2958 rfirst = rlast = 0xffffffff;
2959 }
2960 }
2961
2962 /* now see which range will peter our first, if either. */
2963 tdiff = tlast - tfirst;
2964 rdiff = rlast - rfirst;
2965
2966 if (tdiff <= rdiff)
2967 diff = tdiff;
2968 else
2969 diff = rdiff;
2970
2971 if (rfirst == 0xffffffff) {
2972 diff = tdiff; /* oops, pretend rdiff is infinite */
2973 if (diff > 0)
894356b3
GS		 2974 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
2975 (long)tfirst, (long)tlast);
a0ed51b3 2976 else
894356b3 2977 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
a0ed51b3
LW		 2978 }
2979 else {
2980 if (diff > 0)
894356b3
GS		 2981 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
2982 (long)tfirst, (long)(tfirst + diff),
2983 (long)rfirst);
a0ed51b3 2984 else
894356b3
GS		 2985 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
2986 (long)tfirst, (long)rfirst);
a0ed51b3
LW		 2987
2988 if (rfirst + diff > max)
2989 max = rfirst + diff;
9b877dbb 2990 if (!grows)
45005bfb
JH		 2991 grows = (tfirst < rfirst &&
2992 UNISKIP(tfirst) < UNISKIP(rfirst + diff));
2993 rfirst += diff + 1;
a0ed51b3
LW		 2994 }
2995 tfirst += diff + 1;
2996 }
2997
2998 none = ++max;
2999 if (del)
3000 del = ++max;
3001
3002 if (max > 0xffff)
3003 bits = 32;
3004 else if (max > 0xff)
3005 bits = 16;
3006 else
3007 bits = 8;
3008
455d824a 3009 Safefree(cPVOPo->op_pv);
b3123a61 3010 cPVOPo->op_pv = NULL;
a0ed51b3
LW		 3011 cSVOPo->op_sv = (SV*)swash_init("utf8", "", listsv, bits, none);
3012 SvREFCNT_dec(listsv);
b37c2d43 3013 SvREFCNT_dec(transv);
a0ed51b3 3014
45005bfb 3015 if (!del && havefinal && rlen)
b448e4fe
JH		 3016 (void)hv_store((HV*)SvRV((cSVOPo->op_sv)), "FINAL", 5,
3017 newSVuv((UV)final), 0);
a0ed51b3 3018
9b877dbb 3019 if (grows)
a0ed51b3
LW		 3020 o->op_private |= OPpTRANS_GROWS;
3021
b37c2d43
AL		 3022 Safefree(tsave);
3023 Safefree(rsave);
9b877dbb 3024
eb8433b7
NC		 3025#ifdef PERL_MAD
3026 op_getmad(expr,o,'e');
3027 op_getmad(repl,o,'r');
3028#else
a0ed51b3
LW		 3029 op_free(expr);
3030 op_free(repl);
eb8433b7 3031#endif
a0ed51b3
LW		 3032 return o;
3033 }
3034
3035 tbl = (short*)cPVOPo->op_pv;
79072805
LW		 3036 if (complement) {
3037 Zero(tbl, 256, short);
eb160463 3038 for (i = 0; i < (I32)tlen; i++)
ec49126f 3039 tbl[t[i]] = -1;
79072805
LW		 3040 for (i = 0, j = 0; i < 256; i++) {
3041 if (!tbl[i]) {
eb160463 3042 if (j >= (I32)rlen) {
a0ed51b3 3043 if (del)
79072805
LW		 3044 tbl[i] = -2;
3045 else if (rlen)
ec49126f 3046 tbl[i] = r[j-1];
79072805 3047 else
eb160463 3048 tbl[i] = (short)i;
79072805 3049 }
9b877dbb
IH		 3050 else {
3051 if (i < 128 && r[j] >= 128)
3052 grows = 1;
ec49126f 3053 tbl[i] = r[j++];
9b877dbb 3054 }
79072805
LW		 3055 }
3056 }
05d340b8
JH		 3057 if (!del) {
3058 if (!rlen) {
3059 j = rlen;
3060 if (!squash)
3061 o->op_private |= OPpTRANS_IDENTICAL;
3062 }
eb160463 3063 else if (j >= (I32)rlen)
05d340b8
JH		 3064 j = rlen - 1;
3065 else
3066 cPVOPo->op_pv = (char*)Renew(tbl, 0x101+rlen-j, short);
585ec06d 3067 tbl[0x100] = (short)(rlen - j);
eb160463 3068 for (i=0; i < (I32)rlen - j; i++)
8973db79
JH		 3069 tbl[0x101+i] = r[j+i];
3070 }
79072805
LW		 3071 }
3072 else {
a0ed51b3 3073 if (!rlen && !del) {
79072805 3074 r = t; rlen = tlen;
5d06d08e 3075 if (!squash)
4757a243 3076 o->op_private |= OPpTRANS_IDENTICAL;
79072805 3077 }
94bfe852
RGS		 3078 else if (!squash && rlen == tlen && memEQ((char*)t, (char*)r, tlen)) {
3079 o->op_private |= OPpTRANS_IDENTICAL;
3080 }
79072805
LW		 3081 for (i = 0; i < 256; i++)
3082 tbl[i] = -1;
eb160463
GS		 3083 for (i = 0, j = 0; i < (I32)tlen; i++,j++) {
3084 if (j >= (I32)rlen) {
a0ed51b3 3085 if (del) {
ec49126f 3086 if (tbl[t[i]] == -1)
3087 tbl[t[i]] = -2;
79072805
LW		 3088 continue;
3089 }
3090 --j;
3091 }
9b877dbb
IH		 3092 if (tbl[t[i]] == -1) {
3093 if (t[i] < 128 && r[j] >= 128)
3094 grows = 1;
ec49126f 3095 tbl[t[i]] = r[j];
9b877dbb 3096 }
79072805
LW		 3097 }
3098 }
9b877dbb
IH		 3099 if (grows)
3100 o->op_private |= OPpTRANS_GROWS;
eb8433b7
NC		 3101#ifdef PERL_MAD
3102 op_getmad(expr,o,'e');
3103 op_getmad(repl,o,'r');
3104#else
79072805
LW		 3105 op_free(expr);
3106 op_free(repl);
eb8433b7 3107#endif
79072805 3108
11343788 3109 return o;
79072805
LW		 3110}
3111
3112OP *
864dbfa3 3113Perl_newPMOP(pTHX_ I32 type, I32 flags)
79072805 3114{
27da23d5 3115 dVAR;
79072805
LW		 3116 PMOP *pmop;
3117
b7dc083c 3118 NewOp(1101, pmop, 1, PMOP);
eb160463 3119 pmop->op_type = (OPCODE)type;
22c35a8c 3120 pmop->op_ppaddr = PL_ppaddr[type];
eb160463
GS		 3121 pmop->op_flags = (U8)flags;
3122 pmop->op_private = (U8)(0 | (flags >> 8));
79072805 3123
3280af22 3124 if (PL_hints & HINT_RE_TAINT)
b3eb6a9b 3125 pmop->op_pmpermflags |= PMf_RETAINT;
3280af22 3126 if (PL_hints & HINT_LOCALE)
b3eb6a9b
GS		 3127 pmop->op_pmpermflags |= PMf_LOCALE;
3128 pmop->op_pmflags = pmop->op_pmpermflags;
36477c24 3129
debc9467 3130#ifdef USE_ITHREADS
551405c4
AL		 3131 if (av_len((AV*) PL_regex_pad[0]) > -1) {
3132 SV * const repointer = av_pop((AV*)PL_regex_pad[0]);
3133 pmop->op_pmoffset = SvIV(repointer);
3134 SvREPADTMP_off(repointer);
3135 sv_setiv(repointer,0);
3136 } else {
3137 SV * const repointer = newSViv(0);
b37c2d43 3138 av_push(PL_regex_padav, SvREFCNT_inc_simple_NN(repointer));
551405c4
AL		 3139 pmop->op_pmoffset = av_len(PL_regex_padav);
3140 PL_regex_pad = AvARRAY(PL_regex_padav);
13137afc 3141 }
debc9467 3142#endif
1eb1540c 3143
1fcf4c12 3144 /* link into pm list */
3280af22 3145 if (type != OP_TRANS && PL_curstash) {
8d2f4536
NC		 3146 MAGIC *mg = mg_find((SV*)PL_curstash, PERL_MAGIC_symtab);
3147
3148 if (!mg) {
3149 mg = sv_magicext((SV*)PL_curstash, 0, PERL_MAGIC_symtab, 0, 0, 0);
3150 }
3151 pmop->op_pmnext = (PMOP*)mg->mg_obj;
3152 mg->mg_obj = (SV*)pmop;
cb55de95 3153 PmopSTASH_set(pmop,PL_curstash);
79072805
LW		 3154 }
3155
463d09e6 3156 return CHECKOP(type, pmop);
79072805
LW		 3157}
3158
131b3ad0
DM		 3159/* Given some sort of match op o, and an expression expr containing a
3160 * pattern, either compile expr into a regex and attach it to o (if it's
3161 * constant), or convert expr into a runtime regcomp op sequence (if it's
3162 * not)
3163 *
3164 * isreg indicates that the pattern is part of a regex construct, eg
3165 * $x =~ /pattern/ or split /pattern/, as opposed to $x =~ $pattern or
3166 * split "pattern", which aren't. In the former case, expr will be a list
3167 * if the pattern contains more than one term (eg /a$b/) or if it contains
3168 * a replacement, ie s/// or tr///.
3169 */
3170
79072805 3171OP *
131b3ad0 3172Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg)
79072805 3173{
27da23d5 3174 dVAR;
79072805
LW		 3175 PMOP *pm;
3176 LOGOP *rcop;
ce862d02 3177 I32 repl_has_vars = 0;
5f66b61c 3178 OP* repl = NULL;
131b3ad0
DM		 3179 bool reglist;
3180
3181 if (o->op_type == OP_SUBST || o->op_type == OP_TRANS) {
3182 /* last element in list is the replacement; pop it */
3183 OP* kid;
3184 repl = cLISTOPx(expr)->op_last;
3185 kid = cLISTOPx(expr)->op_first;
3186 while (kid->op_sibling != repl)
3187 kid = kid->op_sibling;
5f66b61c 3188 kid->op_sibling = NULL;
131b3ad0
DM		 3189 cLISTOPx(expr)->op_last = kid;
3190 }
79072805 3191
131b3ad0
DM		 3192 if (isreg && expr->op_type == OP_LIST &&
3193 cLISTOPx(expr)->op_first->op_sibling == cLISTOPx(expr)->op_last)
3194 {
3195 /* convert single element list to element */
0bd48802 3196 OP* const oe = expr;
131b3ad0 3197 expr = cLISTOPx(oe)->op_first->op_sibling;
5f66b61c
AL		 3198 cLISTOPx(oe)->op_first->op_sibling = NULL;
3199 cLISTOPx(oe)->op_last = NULL;
131b3ad0
DM		 3200 op_free(oe);
3201 }
3202
3203 if (o->op_type == OP_TRANS) {
11343788 3204 return pmtrans(o, expr, repl);
131b3ad0
DM		 3205 }
3206
3207 reglist = isreg && expr->op_type == OP_LIST;
3208 if (reglist)
3209 op_null(expr);
79072805 3210
3280af22 3211 PL_hints |= HINT_BLOCK_SCOPE;
11343788 3212 pm = (PMOP*)o;
79072805
LW		 3213
3214 if (expr->op_type == OP_CONST) {
463ee0b2 3215 STRLEN plen;
6136c704 3216 SV * const pat = ((SVOP*)expr)->op_sv;
5c144d81 3217 const char *p = SvPV_const(pat, plen);
770526c1 3218 if ((o->op_flags & OPf_SPECIAL) && (*p == ' ' && p[1] == '\0')) {
5c144d81
NC		 3219 U32 was_readonly = SvREADONLY(pat);
3220
3221 if (was_readonly) {
3222 if (SvFAKE(pat)) {
3223 sv_force_normal_flags(pat, 0);
3224 assert(!SvREADONLY(pat));
3225 was_readonly = 0;
3226 } else {
3227 SvREADONLY_off(pat);
3228 }
3229 }
3230
93a17b20 3231 sv_setpvn(pat, "\\s+", 3);
5c144d81
NC		 3232
3233 SvFLAGS(pat) |= was_readonly;
3234
3235 p = SvPV_const(pat, plen);
79072805
LW		 3236 pm->op_pmflags |= PMf_SKIPWHITE;
3237 }
5b71a6a7 3238 if (DO_UTF8(pat))
a5961de5 3239 pm->op_pmdynflags |= PMdf_UTF8;
5c144d81 3240 /* FIXME - can we make this function take const char * args? */
f9f4320a 3241 PM_SETRE(pm, CALLREGCOMP((char*)p, (char*)p + plen, pm));
aaa362c4 3242 if (strEQ("\\s+", PM_GETRE(pm)->precomp))
85e6fe83 3243 pm->op_pmflags |= PMf_WHITE;
eb8433b7
NC		 3244#ifdef PERL_MAD
3245 op_getmad(expr,(OP*)pm,'e');
3246#else
79072805 3247 op_free(expr);
eb8433b7 3248#endif
79072805
LW		 3249 }
3250 else {
3280af22 3251 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL))
1c846c1f 3252 expr = newUNOP((!(PL_hints & HINT_RE_EVAL)
2cd61cdb
IZ		 3253 ? OP_REGCRESET
3254 : OP_REGCMAYBE),0,expr);
463ee0b2 3255
b7dc083c 3256 NewOp(1101, rcop, 1, LOGOP);
79072805 3257 rcop->op_type = OP_REGCOMP;
22c35a8c 3258 rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP];
79072805 3259 rcop->op_first = scalar(expr);
131b3ad0
DM		 3260 rcop->op_flags |= OPf_KIDS
3261 | ((PL_hints & HINT_RE_EVAL) ? OPf_SPECIAL : 0)
3262 | (reglist ? OPf_STACKED : 0);
79072805 3263 rcop->op_private = 1;
11343788 3264 rcop->op_other = o;
131b3ad0
DM		 3265 if (reglist)
3266 rcop->op_targ = pad_alloc(rcop->op_type, SVs_PADTMP);
3267
b5c19bd7
DM		 3268 /* /$x/ may cause an eval, since $x might be qr/(?{..})/ */
3269 PL_cv_has_eval = 1;
79072805
LW		 3270
3271 /* establish postfix order */
3280af22 3272 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL)) {
463ee0b2
LW		 3273 LINKLIST(expr);
3274 rcop->op_next = expr;
3275 ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
3276 }
3277 else {
3278 rcop->op_next = LINKLIST(expr);
3279 expr->op_next = (OP*)rcop;
3280 }
79072805 3281
11343788 3282 prepend_elem(o->op_type, scalar((OP*)rcop), o);
79072805
LW		 3283 }
3284
3285 if (repl) {
748a9306 3286 OP *curop;
0244c3a4 3287 if (pm->op_pmflags & PMf_EVAL) {
6136c704 3288 curop = NULL;
8bafa735 3289 if (CopLINE(PL_curcop) < (line_t)PL_multi_end)
eb160463 3290 CopLINE_set(PL_curcop, (line_t)PL_multi_end);
0244c3a4 3291 }
748a9306
LW		 3292 else if (repl->op_type == OP_CONST)
3293 curop = repl;
79072805 3294 else {
c445ea15 3295 OP *lastop = NULL;
79072805 3296 for (curop = LINKLIST(repl); curop!=repl; curop = LINKLIST(curop)) {
22c35a8c 3297 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
79072805 3298 if (curop->op_type == OP_GV) {
6136c704 3299 GV * const gv = cGVOPx_gv(curop);
ce862d02 3300 repl_has_vars = 1;
f702bf4a 3301 if (strchr("&`'123456789+-\016\022", *GvENAME(gv)))
79072805
LW		 3302 break;
3303 }
3304 else if (curop->op_type == OP_RV2CV)
3305 break;
3306 else if (curop->op_type == OP_RV2SV ||
3307 curop->op_type == OP_RV2AV ||
3308 curop->op_type == OP_RV2HV ||
3309 curop->op_type == OP_RV2GV) {
3310 if (lastop && lastop->op_type != OP_GV) /*funny deref?*/
3311 break;
3312 }
748a9306
LW		 3313 else if (curop->op_type == OP_PADSV ||
3314 curop->op_type == OP_PADAV ||
3315 curop->op_type == OP_PADHV ||
554b3eca 3316 curop->op_type == OP_PADANY) {
ce862d02 3317 repl_has_vars = 1;
748a9306 3318 }
1167e5da 3319 else if (curop->op_type == OP_PUSHRE)
6f207bd3 3320 NOOP; /* Okay here, dangerous in newASSIGNOP */
79072805
LW		 3321 else
3322 break;
3323 }
3324 lastop = curop;
3325 }
748a9306 3326 }
ce862d02 3327 if (curop == repl
1c846c1f 3328 && !(repl_has_vars
aaa362c4 3329 && (!PM_GETRE(pm)
bbe252da 3330 || PM_GETRE(pm)->extflags & RXf_EVAL_SEEN))) {
748a9306 3331 pm->op_pmflags |= PMf_CONST; /* const for long enough */
4633a7c4 3332 pm->op_pmpermflags |= PMf_CONST; /* const for long enough */
11343788 3333 prepend_elem(o->op_type, scalar(repl), o);
748a9306
LW		 3334 }
3335 else {
aaa362c4 3336 if (curop == repl && !PM_GETRE(pm)) { /* Has variables. */
ce862d02
IZ		 3337 pm->op_pmflags |= PMf_MAYBE_CONST;
3338 pm->op_pmpermflags |= PMf_MAYBE_CONST;
3339 }
b7dc083c 3340 NewOp(1101, rcop, 1, LOGOP);
748a9306 3341 rcop->op_type = OP_SUBSTCONT;
22c35a8c 3342 rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT];
748a9306
LW		 3343 rcop->op_first = scalar(repl);
3344 rcop->op_flags |= OPf_KIDS;
3345 rcop->op_private = 1;
11343788 3346 rcop->op_other = o;
748a9306
LW		 3347
3348 /* establish postfix order */
3349 rcop->op_next = LINKLIST(repl);
3350 repl->op_next = (OP*)rcop;
3351
3352 pm->op_pmreplroot = scalar((OP*)rcop);
3353 pm->op_pmreplstart = LINKLIST(rcop);
3354 rcop->op_next = 0;
79072805
LW		 3355 }
3356 }
3357
3358 return (OP*)pm;
3359}
3360
3361OP *
864dbfa3 3362Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
79072805 3363{
27da23d5 3364 dVAR;
79072805 3365 SVOP *svop;
b7dc083c 3366 NewOp(1101, svop, 1, SVOP);
eb160463 3367 svop->op_type = (OPCODE)type;
22c35a8c 3368 svop->op_ppaddr = PL_ppaddr[type];
79072805
LW		 3369 svop->op_sv = sv;
3370 svop->op_next = (OP*)svop;
eb160463 3371 svop->op_flags = (U8)flags;
22c35a8c 3372 if (PL_opargs[type] & OA_RETSCALAR)
463ee0b2 3373 scalar((OP*)svop);
22c35a8c 3374 if (PL_opargs[type] & OA_TARGET)
ed6116ce 3375 svop->op_targ = pad_alloc(type, SVs_PADTMP);
e50aee73 3376 return CHECKOP(type, svop);
79072805
LW		 3377}
3378
3379OP *
350de78d
GS		 3380Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
3381{
27da23d5 3382 dVAR;
350de78d
GS		 3383 PADOP *padop;
3384 NewOp(1101, padop, 1, PADOP);
eb160463 3385 padop->op_type = (OPCODE)type;
350de78d
GS		 3386 padop->op_ppaddr = PL_ppaddr[type];
3387 padop->op_padix = pad_alloc(type, SVs_PADTMP);
dd2155a4
DM		 3388 SvREFCNT_dec(PAD_SVl(padop->op_padix));
3389 PAD_SETSV(padop->op_padix, sv);
ce50c033
AMS		 3390 if (sv)
3391 SvPADTMP_on(sv);
350de78d 3392 padop->op_next = (OP*)padop;
eb160463 3393 padop->op_flags = (U8)flags;
350de78d
GS		 3394 if (PL_opargs[type] & OA_RETSCALAR)
3395 scalar((OP*)padop);
3396 if (PL_opargs[type] & OA_TARGET)
3397 padop->op_targ = pad_alloc(type, SVs_PADTMP);
3398 return CHECKOP(type, padop);
3399}
3400
3401OP *
864dbfa3 3402Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
79072805 3403{
27da23d5 3404 dVAR;
350de78d 3405#ifdef USE_ITHREADS
ce50c033
AMS		 3406 if (gv)
3407 GvIN_PAD_on(gv);
b37c2d43 3408 return newPADOP(type, flags, SvREFCNT_inc_simple(gv));
350de78d 3409#else
b37c2d43 3410 return newSVOP(type, flags, SvREFCNT_inc_simple(gv));
350de78d 3411#endif
79072805
LW		 3412}
3413
3414OP *
864dbfa3 3415Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
79072805 3416{
27da23d5 3417 dVAR;
79072805 3418 PVOP *pvop;
b7dc083c 3419 NewOp(1101, pvop, 1, PVOP);
eb160463 3420 pvop->op_type = (OPCODE)type;
22c35a8c 3421 pvop->op_ppaddr = PL_ppaddr[type];
79072805
LW		 3422 pvop->op_pv = pv;
3423 pvop->op_next = (OP*)pvop;
eb160463 3424 pvop->op_flags = (U8)flags;
22c35a8c 3425 if (PL_opargs[type] & OA_RETSCALAR)
463ee0b2 3426 scalar((OP*)pvop);
22c35a8c 3427 if (PL_opargs[type] & OA_TARGET)
ed6116ce 3428 pvop->op_targ = pad_alloc(type, SVs_PADTMP);
e50aee73 3429 return CHECKOP(type, pvop);
79072805
LW		 3430}
3431
eb8433b7
NC		 3432#ifdef PERL_MAD
3433OP*
3434#else
79072805 3435void
eb8433b7 3436#endif
864dbfa3 3437Perl_package(pTHX_ OP *o)
79072805 3438{
97aff369 3439 dVAR;
6867be6d 3440 const char *name;
de11ba31 3441 STRLEN len;
eb8433b7
NC		 3442#ifdef PERL_MAD
3443 OP *pegop;
3444#endif
79072805 3445
3280af22
NIS		 3446 save_hptr(&PL_curstash);
3447 save_item(PL_curstname);
de11ba31 3448
5c144d81 3449 name = SvPV_const(cSVOPo->op_sv, len);
de11ba31
AMS		 3450 PL_curstash = gv_stashpvn(name, len, TRUE);
3451 sv_setpvn(PL_curstname, name, len);
de11ba31 3452
7ad382f4 3453 PL_hints |= HINT_BLOCK_SCOPE;
3280af22
NIS		 3454 PL_copline = NOLINE;
3455 PL_expect = XSTATE;
eb8433b7
NC		 3456
3457#ifndef PERL_MAD
3458 op_free(o);
3459#else
3460 if (!PL_madskills) {
3461 op_free(o);
1d866c12 3462 return NULL;
eb8433b7
NC		 3463 }
3464
3465 pegop = newOP(OP_NULL,0);
3466 op_getmad(o,pegop,'P');
3467 return pegop;
3468#endif
79072805
LW		 3469}
3470
eb8433b7
NC		 3471#ifdef PERL_MAD
3472OP*
3473#else
85e6fe83 3474void
eb8433b7 3475#endif
88d95a4d 3476Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg)
85e6fe83 3477{
97aff369 3478 dVAR;
a0d0e21e 3479 OP *pack;
a0d0e21e 3480 OP *imop;
b1cb66bf 3481 OP *veop;
eb8433b7
NC		 3482#ifdef PERL_MAD
3483 OP *pegop = newOP(OP_NULL,0);
3484#endif
85e6fe83 3485
88d95a4d 3486 if (idop->op_type != OP_CONST)
cea2e8a9 3487 Perl_croak(aTHX_ "Module name must be constant");
85e6fe83 3488
eb8433b7
NC		 3489 if (PL_madskills)
3490 op_getmad(idop,pegop,'U');
3491
5f66b61c 3492 veop = NULL;
b1cb66bf 3493
aec46f14 3494 if (version) {
551405c4 3495 SV * const vesv = ((SVOP*)version)->op_sv;
b1cb66bf 3496
eb8433b7
NC		 3497 if (PL_madskills)
3498 op_getmad(version,pegop,'V');
aec46f14 3499 if (!arg && !SvNIOKp(vesv)) {
b1cb66bf 3500 arg = version;
3501 }
3502 else {
3503 OP *pack;
0f79a09d 3504 SV *meth;
b1cb66bf 3505
44dcb63b 3506 if (version->op_type != OP_CONST || !SvNIOKp(vesv))
cea2e8a9 3507 Perl_croak(aTHX_ "Version number must be constant number");
b1cb66bf 3508
88d95a4d
JH		 3509 /* Make copy of idop so we don't free it twice */
3510 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
b1cb66bf 3511
3512 /* Fake up a method call to VERSION */
18916d0d 3513 meth = newSVpvs_share("VERSION");
b1cb66bf 3514 veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3515 append_elem(OP_LIST,
0f79a09d
GS		 3516 prepend_elem(OP_LIST, pack, list(version)),
3517 newSVOP(OP_METHOD_NAMED, 0, meth)));
b1cb66bf 3518 }
3519 }
aeea060c 3520
a0d0e21e 3521 /* Fake up an import/unimport */
eb8433b7
NC		 3522 if (arg && arg->op_type == OP_STUB) {
3523 if (PL_madskills)
3524 op_getmad(arg,pegop,'S');
4633a7c4 3525 imop = arg; /* no import on explicit () */
eb8433b7 3526 }
88d95a4d 3527 else if (SvNIOKp(((SVOP*)idop)->op_sv)) {
5f66b61c 3528 imop = NULL; /* use 5.0; */
468aa647
RGS		 3529 if (!aver)
3530 idop->op_private |= OPpCONST_NOVER;
b1cb66bf 3531 }
4633a7c4 3532 else {
0f79a09d
GS		 3533 SV *meth;
3534
eb8433b7
NC		 3535 if (PL_madskills)
3536 op_getmad(arg,pegop,'A');
3537
88d95a4d
JH		 3538 /* Make copy of idop so we don't free it twice */
3539 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
0f79a09d
GS		 3540
3541 /* Fake up a method call to import/unimport */
427d62a4 3542 meth = aver
18916d0d 3543 ? newSVpvs_share("import") : newSVpvs_share("unimport");
4633a7c4 3544 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
0f79a09d
GS		 3545 append_elem(OP_LIST,
3546 prepend_elem(OP_LIST, pack, list(arg)),
3547 newSVOP(OP_METHOD_NAMED, 0, meth)));
4633a7c4
LW		 3548 }
3549
a0d0e21e 3550 /* Fake up the BEGIN {}, which does its thing immediately. */
09bef843 3551 newATTRSUB(floor,
18916d0d 3552 newSVOP(OP_CONST, 0, newSVpvs_share("BEGIN")),
5f66b61c
AL		 3553 NULL,
3554 NULL,
a0d0e21e 3555 append_elem(OP_LINESEQ,
b1cb66bf 3556 append_elem(OP_LINESEQ,
bd61b366
SS		 3557 newSTATEOP(0, NULL, newUNOP(OP_REQUIRE, 0, idop)),
3558 newSTATEOP(0, NULL, veop)),
3559 newSTATEOP(0, NULL, imop) ));
85e6fe83 3560
70f5e4ed
JH		 3561 /* The "did you use incorrect case?" warning used to be here.
3562 * The problem is that on case-insensitive filesystems one
3563 * might get false positives for "use" (and "require"):
3564 * "use Strict" or "require CARP" will work. This causes
3565 * portability problems for the script: in case-strict
3566 * filesystems the script will stop working.
3567 *
3568 * The "incorrect case" warning checked whether "use Foo"
3569 * imported "Foo" to your namespace, but that is wrong, too:
3570 * there is no requirement nor promise in the language that
3571 * a Foo.pm should or would contain anything in package "Foo".
3572 *
3573 * There is very little Configure-wise that can be done, either:
3574 * the case-sensitivity of the build filesystem of Perl does not
3575 * help in guessing the case-sensitivity of the runtime environment.
3576 */
18fc9488 3577
c305c6a0 3578 PL_hints |= HINT_BLOCK_SCOPE;
3280af22
NIS		 3579 PL_copline = NOLINE;
3580 PL_expect = XSTATE;
8ec8fbef 3581 PL_cop_seqmax++; /* Purely for B::*'s benefit */
eb8433b7
NC		 3582
3583#ifdef PERL_MAD
3584 if (!PL_madskills) {
3585 /* FIXME - don't allocate pegop if !PL_madskills */
3586 op_free(pegop);
1d866c12 3587 return NULL;
eb8433b7
NC		 3588 }
3589 return pegop;
3590#endif
85e6fe83
LW		 3591}
3592
7d3fb230 3593/*
ccfc67b7
JH		 3594=head1 Embedding Functions
3595
7d3fb230
BS		 3596=for apidoc load_module
3597
3598Loads the module whose name is pointed to by the string part of name.
3599Note that the actual module name, not its filename, should be given.
3600Eg, "Foo::Bar" instead of "Foo/Bar.pm". flags can be any of
3601PERL_LOADMOD_DENY, PERL_LOADMOD_NOIMPORT, or PERL_LOADMOD_IMPORT_OPS
3602(or 0 for no flags). ver, if specified, provides version semantics
3603similar to C<use Foo::Bar VERSION>. The optional trailing SV*
3604arguments can be used to specify arguments to the module's import()
3605method, similar to C<use Foo::Bar VERSION LIST>.
3606
3607=cut */
3608
e4783991
GS		 3609void
3610Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
3611{
3612 va_list args;
3613 va_start(args, ver);
3614 vload_module(flags, name, ver, &args);
3615 va_end(args);
3616}
3617
3618#ifdef PERL_IMPLICIT_CONTEXT
3619void
3620Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
3621{
3622 dTHX;
3623 va_list args;
3624 va_start(args, ver);
3625 vload_module(flags, name, ver, &args);
3626 va_end(args);
3627}
3628#endif
3629
3630void
3631Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
3632{
97aff369 3633 dVAR;
551405c4 3634 OP *veop, *imop;
e4783991 3635
551405c4 3636 OP * const modname = newSVOP(OP_CONST, 0, name);
e4783991
GS		 3637 modname->op_private |= OPpCONST_BARE;
3638 if (ver) {
3639 veop = newSVOP(OP_CONST, 0, ver);
3640 }
3641 else
5f66b61c 3642 veop = NULL;
e4783991
GS		 3643 if (flags & PERL_LOADMOD_NOIMPORT) {
3644 imop = sawparens(newNULLLIST());
3645 }
3646 else if (flags & PERL_LOADMOD_IMPORT_OPS) {
3647 imop = va_arg(*args, OP*);
3648 }
3649 else {
3650 SV *sv;
5f66b61c 3651 imop = NULL;
e4783991
GS		 3652 sv = va_arg(*args, SV*);
3653 while (sv) {
3654 imop = append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
3655 sv = va_arg(*args, SV*);
3656 }
3657 }
81885997 3658 {
6867be6d
AL		 3659 const line_t ocopline = PL_copline;
3660 COP * const ocurcop = PL_curcop;
3661 const int oexpect = PL_expect;
81885997
GS		 3662
3663 utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
3664 veop, modname, imop);
3665 PL_expect = oexpect;
3666 PL_copline = ocopline;
834a3ffa 3667 PL_curcop = ocurcop;
81885997 3668 }
e4783991
GS		 3669}
3670
79072805 3671OP *
850e8516 3672Perl_dofile(pTHX_ OP *term, I32 force_builtin)
78ca652e 3673{
97aff369 3674 dVAR;
78ca652e 3675 OP *doop;
a0714e2c 3676 GV *gv = NULL;
78ca652e 3677
850e8516 3678 if (!force_builtin) {
fafc274c 3679 gv = gv_fetchpvs("do", GV_NOTQUAL, SVt_PVCV);
850e8516 3680 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
a4fc7abc 3681 GV * const * const gvp = (GV**)hv_fetchs(PL_globalstash, "do", FALSE);
a0714e2c 3682 gv = gvp ? *gvp : NULL;
850e8516
RGS		 3683 }
3684 }
78ca652e 3685
b9f751c0 3686 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
78ca652e
GS		 3687 doop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
3688 append_elem(OP_LIST, term,
3689 scalar(newUNOP(OP_RV2CV, 0,
d4c19fe8 3690 newGVOP(OP_GV, 0, gv))))));
78ca652e
GS		 3691 }
3692 else {
3693 doop = newUNOP(OP_DOFILE, 0, scalar(term));
3694 }
3695 return doop;
3696}
3697
3698OP *
864dbfa3 3699Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
79072805
LW		 3700{
3701 return newBINOP(OP_LSLICE, flags,
8990e307
LW		 3702 list(force_list(subscript)),
3703 list(force_list(listval)) );
79072805
LW		 3704}
3705
76e3520e 3706STATIC I32
504618e9 3707S_is_list_assignment(pTHX_ register const OP *o)
79072805 3708{
1496a290
AL		 3709 unsigned type;
3710 U8 flags;
3711
11343788 3712 if (!o)
79072805
LW		 3713 return TRUE;
3714
1496a290 3715 if ((o->op_type == OP_NULL) && (o->op_flags & OPf_KIDS))
11343788 3716 o = cUNOPo->op_first;
79072805 3717
1496a290
AL		 3718 flags = o->op_flags;
3719 type = o->op_type;
3720 if (type == OP_COND_EXPR) {
504618e9
AL		 3721 const I32 t = is_list_assignment(cLOGOPo->op_first->op_sibling);
3722 const I32 f = is_list_assignment(cLOGOPo->op_first->op_sibling->op_sibling);
79072805
LW		 3723
3724 if (t && f)
3725 return TRUE;
3726 if (t || f)
3727 yyerror("Assignment to both a list and a scalar");
3728 return FALSE;
3729 }
3730
1496a290
AL		 3731 if (type == OP_LIST &&
3732 (flags & OPf_WANT) == OPf_WANT_SCALAR &&
95f0a2f1
SB		 3733 o->op_private & OPpLVAL_INTRO)
3734 return FALSE;
3735
1496a290
AL		 3736 if (type == OP_LIST || flags & OPf_PARENS ||
3737 type == OP_RV2AV || type == OP_RV2HV ||
3738 type == OP_ASLICE || type == OP_HSLICE)
79072805
LW		 3739 return TRUE;
3740
1496a290 3741 if (type == OP_PADAV || type == OP_PADHV)
93a17b20
LW		 3742 return TRUE;
3743
1496a290 3744 if (type == OP_RV2SV)
79072805
LW		 3745 return FALSE;
3746
3747 return FALSE;
3748}
3749
3750OP *
864dbfa3 3751Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
79072805 3752{
97aff369 3753 dVAR;
11343788 3754 OP *o;
79072805 3755
a0d0e21e 3756 if (optype) {
c963b151 3757 if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN || optype == OP_DORASSIGN) {
a0d0e21e
LW		 3758 return newLOGOP(optype, 0,
3759 mod(scalar(left), optype),
3760 newUNOP(OP_SASSIGN, 0, scalar(right)));
3761 }
3762 else {
3763 return newBINOP(optype, OPf_STACKED,
3764 mod(scalar(left), optype), scalar(right));
3765 }
3766 }
3767
504618e9 3768 if (is_list_assignment(left)) {
10c8fecd
GS		 3769 OP *curop;
3770
3280af22 3771 PL_modcount = 0;
dbfe47cf
RD		 3772 /* Grandfathering $[ assignment here. Bletch.*/
3773 /* Only simple assignments like C<< ($[) = 1 >> are allowed */
3774 PL_eval_start = (left->op_type == OP_CONST) ? right : 0;
463ee0b2 3775 left = mod(left, OP_AASSIGN);
3280af22
NIS		 3776 if (PL_eval_start)
3777 PL_eval_start = 0;
dbfe47cf 3778 else if (left->op_type == OP_CONST) {
eb8433b7 3779 /* FIXME for MAD */
dbfe47cf
RD		 3780 /* Result of assignment is always 1 (or we'd be dead already) */
3781 return newSVOP(OP_CONST, 0, newSViv(1));
a0d0e21e 3782 }
10c8fecd
GS		 3783 curop = list(force_list(left));
3784 o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop);
eb160463 3785 o->op_private = (U8)(0 | (flags >> 8));
dd2155a4
DM		 3786
3787 /* PL_generation sorcery:
3788 * an assignment like ($a,$b) = ($c,$d) is easier than
3789 * ($a,$b) = ($c,$a), since there is no need for temporary vars.
3790 * To detect whether there are common vars, the global var
3791 * PL_generation is incremented for each assign op we compile.
3792 * Then, while compiling the assign op, we run through all the
3793 * variables on both sides of the assignment, setting a spare slot
3794 * in each of them to PL_generation. If any of them already have
3795 * that value, we know we've got commonality. We could use a
3796 * single bit marker, but then we'd have to make 2 passes, first
3797 * to clear the flag, then to test and set it. To find somewhere
3798 * to store these values, evil chicanery is done with SvCUR().
3799 */
3800
461824dc 3801 {
11343788 3802 OP *lastop = o;
3280af22 3803 PL_generation++;
11343788 3804 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
22c35a8c 3805 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
79072805 3806 if (curop->op_type == OP_GV) {
638eceb6 3807 GV *gv = cGVOPx_gv(curop);
169d2d72
NC		 3808 if (gv == PL_defgv
3809 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
79072805 3810 break;
169d2d72 3811 GvASSIGN_GENERATION_set(gv, PL_generation);
79072805 3812 }
748a9306
LW		 3813 else if (curop->op_type == OP_PADSV ||
3814 curop->op_type == OP_PADAV ||
3815 curop->op_type == OP_PADHV ||
dd2155a4
DM		 3816 curop->op_type == OP_PADANY)
3817 {
3818 if (PAD_COMPNAME_GEN(curop->op_targ)
92251a1e 3819 == (STRLEN)PL_generation)
748a9306 3820 break;
b162af07 3821 PAD_COMPNAME_GEN_set(curop->op_targ, PL_generation);
dd2155a4 3822
748a9306 3823 }
79072805
LW		 3824 else if (curop->op_type == OP_RV2CV)
3825 break;
3826 else if (curop->op_type == OP_RV2SV ||
3827 curop->op_type == OP_RV2AV ||
3828 curop->op_type == OP_RV2HV ||
3829 curop->op_type == OP_RV2GV) {
3830 if (lastop->op_type != OP_GV) /* funny deref? */
3831 break;
3832 }
1167e5da
SM		 3833 else if (curop->op_type == OP_PUSHRE) {
3834 if (((PMOP*)curop)->op_pmreplroot) {
b3f5893f 3835#ifdef USE_ITHREADS
dd2155a4
DM		 3836 GV *gv = (GV*)PAD_SVl(INT2PTR(PADOFFSET,
3837 ((PMOP*)curop)->op_pmreplroot));
b3f5893f 3838#else
1167e5da 3839 GV *gv = (GV*)((PMOP*)curop)->op_pmreplroot;
b3f5893f 3840#endif
169d2d72
NC		 3841 if (gv == PL_defgv
3842 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
1167e5da 3843 break;
169d2d72
NC		 3844 GvASSIGN_GENERATION_set(gv, PL_generation);
3845 GvASSIGN_GENERATION_set(gv, PL_generation);
b2ffa427 3846 }
1167e5da 3847 }
79072805
LW		 3848 else
3849 break;
3850 }
3851 lastop = curop;
3852 }
11343788 3853 if (curop != o)
10c8fecd 3854 o->op_private |= OPpASSIGN_COMMON;
461824dc 3855 }
9fdc7570
RGS		 3856
3857 if ( ((left->op_private & OPpLVAL_INTRO) || ckWARN(WARN_MISC))
3858 && (left->op_type == OP_LIST
3859 || (left->op_type == OP_NULL && left->op_targ == OP_LIST)))
3860 {
3861 OP* lop = ((LISTOP*)left)->op_first;
3862 while (lop) {
3863 if (lop->op_type == OP_PADSV ||
3864 lop->op_type == OP_PADAV ||
3865 lop->op_type == OP_PADHV ||
3866 lop->op_type == OP_PADANY)
3867 {
3868 if (lop->op_private & OPpPAD_STATE) {
3869 if (left->op_private & OPpLVAL_INTRO) {
3870 o->op_private |= OPpASSIGN_STATE;
3871 /* hijacking PADSTALE for uninitialized state variables */
3872 SvPADSTALE_on(PAD_SVl(lop->op_targ));
3873 }
3874 else { /* we already checked for WARN_MISC before */
3875 Perl_warner(aTHX_ packWARN(WARN_MISC), "State variable %s will be reinitialized",
3876 PAD_COMPNAME_PV(lop->op_targ));
3877 }
3878 }
3879 }
3880 lop = lop->op_sibling;
3881 }
3882 }
3883
c07a80fd 3884 if (right && right->op_type == OP_SPLIT) {
1496a290
AL		 3885 OP* tmpop = ((LISTOP*)right)->op_first;
3886 if (tmpop && (tmpop->op_type == OP_PUSHRE)) {
551405c4 3887 PMOP * const pm = (PMOP*)tmpop;
c07a80fd 3888 if (left->op_type == OP_RV2AV &&
3889 !(left->op_private & OPpLVAL_INTRO) &&
11343788 3890 !(o->op_private & OPpASSIGN_COMMON) )
c07a80fd 3891 {
3892 tmpop = ((UNOP*)left)->op_first;
3893 if (tmpop->op_type == OP_GV && !pm->op_pmreplroot) {
971a9dd3 3894#ifdef USE_ITHREADS
ba89bb6e 3895 pm->op_pmreplroot = INT2PTR(OP*, cPADOPx(tmpop)->op_padix);
971a9dd3
GS		 3896 cPADOPx(tmpop)->op_padix = 0; /* steal it */
3897#else
3898 pm->op_pmreplroot = (OP*)cSVOPx(tmpop)->op_sv;
a0714e2c 3899 cSVOPx(tmpop)->op_sv = NULL; /* steal it */
971a9dd3 3900#endif
c07a80fd 3901 pm->op_pmflags |= PMf_ONCE;
11343788 3902 tmpop = cUNOPo->op_first; /* to list (nulled) */
c07a80fd 3903 tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
5f66b61c 3904 tmpop->op_sibling = NULL; /* don't free split */
c07a80fd 3905 right->op_next = tmpop->op_next; /* fix starting loc */
eb8433b7
NC		 3906#ifdef PERL_MAD
3907 op_getmad(o,right,'R'); /* blow off assign */
3908#else
11343788 3909 op_free(o); /* blow off assign */
eb8433b7 3910#endif
54310121 3911 right->op_flags &= ~OPf_WANT;
a5f75d66 3912 /* "I don't know and I don't care." */
c07a80fd 3913 return right;
3914 }
3915 }
3916 else {
e6438c1a 3917 if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
c07a80fd 3918 ((LISTOP*)right)->op_last->op_type == OP_CONST)
3919 {
3920 SV *sv = ((SVOP*)((LISTOP*)right)->op_last)->op_sv;
3921 if (SvIVX(sv) == 0)
3280af22 3922 sv_setiv(sv, PL_modcount+1);
c07a80fd 3923 }
3924 }
3925 }
3926 }
11343788 3927 return o;
79072805
LW		 3928 }
3929 if (!right)
3930 right = newOP(OP_UNDEF, 0);
3931 if (right->op_type == OP_READLINE) {
3932 right->op_flags |= OPf_STACKED;
463ee0b2 3933 return newBINOP(OP_NULL, flags, mod(scalar(left), OP_SASSIGN), scalar(right));
79072805 3934 }
a0d0e21e 3935 else {
3280af22 3936 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
11343788 3937 o = newBINOP(OP_SASSIGN, flags,
463ee0b2 3938 scalar(right), mod(scalar(left), OP_SASSIGN) );
3280af22
NIS		 3939 if (PL_eval_start)
3940 PL_eval_start = 0;
748a9306 3941 else {
eb8433b7 3942 /* FIXME for MAD */
3b6547f5 3943 op_free(o);
fc15ae8f 3944 o = newSVOP(OP_CONST, 0, newSViv(CopARYBASE_get(&PL_compiling)));
2e0ae2d3 3945 o->op_private |= OPpCONST_ARYBASE;
a0d0e21e
LW		 3946 }
3947 }
11343788 3948 return o;
79072805
LW		 3949}
3950
3951OP *
864dbfa3 3952Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
79072805 3953{
27da23d5 3954 dVAR;
e1ec3a88 3955 const U32 seq = intro_my();
79072805
LW		 3956 register COP *cop;
3957
b7dc083c 3958 NewOp(1101, cop, 1, COP);
57843af0 3959 if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
8990e307 3960 cop->op_type = OP_DBSTATE;
22c35a8c 3961 cop->op_ppaddr = PL_ppaddr[ OP_DBSTATE ];
8990e307
LW		 3962 }
3963 else {
3964 cop->op_type = OP_NEXTSTATE;
22c35a8c 3965 cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ];
8990e307 3966 }
eb160463 3967 cop->op_flags = (U8)flags;
623e6609 3968 CopHINTS_set(cop, PL_hints);
ff0cee69 3969#ifdef NATIVE_HINTS
3970 cop->op_private |= NATIVE_HINTS;
3971#endif
623e6609 3972 CopHINTS_set(&PL_compiling, CopHINTS_get(cop));
79072805
LW		 3973 cop->op_next = (OP*)cop;
3974
463ee0b2
LW		 3975 if (label) {
3976 cop->cop_label = label;
3280af22 3977 PL_hints |= HINT_BLOCK_SCOPE;
463ee0b2 3978 }
bbce6d69 3979 cop->cop_seq = seq;
7b0bddfa 3980 /* CopARYBASE is now "virtual", in that it's stored as a flag bit in
c28fe1ec
NC		 3981 CopHINTS and a possible value in cop_hints_hash, so no need to copy it.
3982 */
72dc9ed5 3983 cop->cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
c28fe1ec
NC		 3984 cop->cop_hints_hash = PL_curcop->cop_hints_hash;
3985 if (cop->cop_hints_hash) {
cbb1fbea 3986 HINTS_REFCNT_LOCK;
c28fe1ec 3987 cop->cop_hints_hash->refcounted_he_refcnt++;
cbb1fbea 3988 HINTS_REFCNT_UNLOCK;
b3ca2e83 3989 }
79072805 3990
3280af22 3991 if (PL_copline == NOLINE)
57843af0 3992 CopLINE_set(cop, CopLINE(PL_curcop));
79072805 3993 else {
57843af0 3994 CopLINE_set(cop, PL_copline);
3280af22 3995 PL_copline = NOLINE;
79072805 3996 }
57843af0 3997#ifdef USE_ITHREADS
f4dd75d9 3998 CopFILE_set(cop, CopFILE(PL_curcop)); /* XXX share in a pvtable? */
57843af0 3999#else
f4dd75d9 4000 CopFILEGV_set(cop, CopFILEGV(PL_curcop));
57843af0 4001#endif
11faa288 4002 CopSTASH_set(cop, PL_curstash);
79072805 4003
3280af22 4004 if (PERLDB_LINE && PL_curstash != PL_debstash) {
80a702cd
RGS		 4005 AV *av = CopFILEAVx(PL_curcop);
4006 if (av) {
4007 SV * const * const svp = av_fetch(av, (I32)CopLINE(cop), FALSE);
4008 if (svp && *svp != &PL_sv_undef ) {
4009 (void)SvIOK_on(*svp);
4010 SvIV_set(*svp, PTR2IV(cop));
4011 }
1eb1540c 4012 }
93a17b20
LW		 4013 }
4014
722969e2 4015 return prepend_elem(OP_LINESEQ, (OP*)cop, o);
79072805
LW		 4016}
4017
bbce6d69 4018
79072805 4019OP *
864dbfa3 4020Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
79072805 4021{
27da23d5 4022 dVAR;
883ffac3
CS		 4023 return new_logop(type, flags, &first, &other);
4024}
4025
3bd495df 4026STATIC OP *
cea2e8a9 4027S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
883ffac3 4028{
27da23d5 4029 dVAR;
79072805 4030 LOGOP *logop;
11343788 4031 OP *o;
883ffac3 4032 OP *first = *firstp;
b22e6366 4033 OP * const other = *otherp;
79072805 4034
a0d0e21e
LW		 4035 if (type == OP_XOR) /* Not short circuit, but here by precedence. */
4036 return newBINOP(type, flags, scalar(first), scalar(other));
4037
8990e307 4038 scalarboolean(first);
79072805 4039 /* optimize "!a && b" to "a || b", and "!a || b" to "a && b" */
68726e16
NC		 4040 if (first->op_type == OP_NOT
4041 && (first->op_flags & OPf_SPECIAL)
4042 && (first->op_flags & OPf_KIDS)) {
79072805
LW		 4043 if (type == OP_AND || type == OP_OR) {
4044 if (type == OP_AND)
4045 type = OP_OR;
4046 else
4047 type = OP_AND;
11343788 4048 o = first;
883ffac3 4049 first = *firstp = cUNOPo->op_first;
11343788
MB		 4050 if (o->op_next)
4051 first->op_next = o->op_next;
5f66b61c 4052 cUNOPo->op_first = NULL;
eb8433b7
NC		 4053#ifdef PERL_MAD
4054 op_getmad(o,first,'O');
4055#else
11343788 4056 op_free(o);
eb8433b7 4057#endif
79072805
LW		 4058 }
4059 }
4060 if (first->op_type == OP_CONST) {
39a440a3
DM		 4061 if (first->op_private & OPpCONST_STRICT)
4062 no_bareword_allowed(first);
041457d9 4063 else if ((first->op_private & OPpCONST_BARE) && ckWARN(WARN_BAREWORD))
989dfb19 4064 Perl_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional");
75cc09e4
MHM		 4065 if ((type == OP_AND && SvTRUE(((SVOP*)first)->op_sv)) ||
4066 (type == OP_OR && !SvTRUE(((SVOP*)first)->op_sv)) ||
4067 (type == OP_DOR && !SvOK(((SVOP*)first)->op_sv))) {
5f66b61c 4068 *firstp = NULL;
d6fee5c7
DM		 4069 if (other->op_type == OP_CONST)
4070 other->op_private |= OPpCONST_SHORTCIRCUIT;
eb8433b7
NC		 4071 if (PL_madskills) {
4072 OP *newop = newUNOP(OP_NULL, 0, other);
4073 op_getmad(first, newop, '1');
4074 newop->op_targ = type; /* set "was" field */
4075 return newop;
4076 }
4077 op_free(first);
79072805
LW		 4078 return other;
4079 }
4080 else {
7921d0f2 4081 /* check for C<my $x if 0>, or C<my($x,$y) if 0> */
6867be6d 4082 const OP *o2 = other;
7921d0f2
DM		 4083 if ( ! (o2->op_type == OP_LIST
4084 && (( o2 = cUNOPx(o2)->op_first))
4085 && o2->op_type == OP_PUSHMARK
4086 && (( o2 = o2->op_sibling)) )
4087 )
4088 o2 = other;
4089 if ((o2->op_type == OP_PADSV || o2->op_type == OP_PADAV
4090 || o2->op_type == OP_PADHV)
4091 && o2->op_private & OPpLVAL_INTRO
4092 && ckWARN(WARN_DEPRECATED))
4093 {
4094 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
4095 "Deprecated use of my() in false conditional");
4096 }
4097
5f66b61c 4098 *otherp = NULL;
d6fee5c7
DM		 4099 if (first->op_type == OP_CONST)
4100 first->op_private |= OPpCONST_SHORTCIRCUIT;
eb8433b7
NC		 4101 if (PL_madskills) {
4102 first = newUNOP(OP_NULL, 0, first);
4103 op_getmad(other, first, '2');
4104 first->op_targ = type; /* set "was" field */
4105 }
4106 else
4107 op_free(other);
79072805
LW		 4108 return first;
4109 }
4110 }
041457d9
DM		 4111 else if ((first->op_flags & OPf_KIDS) && type != OP_DOR
4112 && ckWARN(WARN_MISC)) /* [#24076] Don't warn for <FH> err FOO. */
59e10468 4113 {
b22e6366
AL		 4114 const OP * const k1 = ((UNOP*)first)->op_first;
4115 const OP * const k2 = k1->op_sibling;
a6006777 4116 OPCODE warnop = 0;
4117 switch (first->op_type)
4118 {
4119 case OP_NULL:
4120 if (k2 && k2->op_type == OP_READLINE
4121 && (k2->op_flags & OPf_STACKED)
1c846c1f 4122 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
72b16652 4123 {
a6006777 4124 warnop = k2->op_type;
72b16652 4125 }
a6006777 4126 break;
4127
4128 case OP_SASSIGN:
68dc0745 4129 if (k1->op_type == OP_READDIR
4130 || k1->op_type == OP_GLOB
72b16652 4131 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
68dc0745 4132 || k1->op_type == OP_EACH)
72b16652
GS		 4133 {
4134 warnop = ((k1->op_type == OP_NULL)
eb160463 4135 ? (OPCODE)k1->op_targ : k1->op_type);
72b16652 4136 }
a6006777 4137 break;
4138 }
8ebc5c01 4139 if (warnop) {
6867be6d 4140 const line_t oldline = CopLINE(PL_curcop);
57843af0 4141 CopLINE_set(PL_curcop, PL_copline);
9014280d 4142 Perl_warner(aTHX_ packWARN(WARN_MISC),
599cee73 4143 "Value of %s%s can be \"0\"; test with defined()",
22c35a8c 4144 PL_op_desc[warnop],
68dc0745 4145 ((warnop == OP_READLINE || warnop == OP_GLOB)
4146 ? " construct" : "() operator"));
57843af0 4147 CopLINE_set(PL_curcop, oldline);
8ebc5c01 4148 }
a6006777 4149 }
79072805
LW		 4150
4151 if (!other)
4152 return first;
4153
c963b151 4154 if (type == OP_ANDASSIGN || type == OP_ORASSIGN || type == OP_DORASSIGN)
a0d0e21e
LW		 4155 other->op_private |= OPpASSIGN_BACKWARDS; /* other is an OP_SASSIGN */
4156
b7dc083c 4157 NewOp(1101, logop, 1, LOGOP);
79072805 4158
eb160463 4159 logop->op_type = (OPCODE)type;
22c35a8c 4160 logop->op_ppaddr = PL_ppaddr[type];
79072805 4161 logop->op_first = first;
585ec06d 4162 logop->op_flags = (U8)(flags | OPf_KIDS);
79072805 4163 logop->op_other = LINKLIST(other);
eb160463 4164 logop->op_private = (U8)(1 | (flags >> 8));
79072805
LW		 4165
4166 /* establish postfix order */
4167 logop->op_next = LINKLIST(first);
4168 first->op_next = (OP*)logop;
4169 first->op_sibling = other;
4170
463d09e6
RGS		 4171 CHECKOP(type,logop);
4172
11343788
MB		 4173 o = newUNOP(OP_NULL, 0, (OP*)logop);
4174 other->op_next = o;
79072805 4175
11343788 4176 return o;
79072805
LW		 4177}
4178
4179OP *
864dbfa3 4180Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
79072805 4181{
27da23d5 4182 dVAR;
1a67a97c
SM		 4183 LOGOP *logop;
4184 OP *start;
11343788 4185 OP *o;
79072805 4186
b1cb66bf 4187 if (!falseop)
4188 return newLOGOP(OP_AND, 0, first, trueop);
4189 if (!trueop)
4190 return newLOGOP(OP_OR, 0, first, falseop);
79072805 4191
8990e307 4192 scalarboolean(first);
79072805 4193 if (first->op_type == OP_CONST) {
2bc6235c 4194 if (first->op_private & OPpCONST_BARE &&
b22e6366
AL		 4195 first->op_private & OPpCONST_STRICT) {
4196 no_bareword_allowed(first);
4197 }
79072805 4198 if (SvTRUE(((SVOP*)first)->op_sv)) {
eb8433b7
NC		 4199#ifdef PERL_MAD
4200 if (PL_madskills) {
4201 trueop = newUNOP(OP_NULL, 0, trueop);
4202 op_getmad(first,trueop,'C');
4203 op_getmad(falseop,trueop,'e');
4204 }
4205 /* FIXME for MAD - should there be an ELSE here? */
4206#else
79072805 4207 op_free(first);
b1cb66bf 4208 op_free(falseop);
eb8433b7 4209#endif
b1cb66bf 4210 return trueop;
79072805
LW		 4211 }
4212 else {
eb8433b7
NC		 4213#ifdef PERL_MAD
4214 if (PL_madskills) {
4215 falseop = newUNOP(OP_NULL, 0, falseop);
4216 op_getmad(first,falseop,'C');
4217 op_getmad(trueop,falseop,'t');
4218 }
4219 /* FIXME for MAD - should there be an ELSE here? */
4220#else
79072805 4221 op_free(first);
b1cb66bf 4222 op_free(trueop);
eb8433b7 4223#endif
b1cb66bf 4224 return falseop;
79072805
LW		 4225 }
4226 }
1a67a97c
SM		 4227 NewOp(1101, logop, 1, LOGOP);
4228 logop->op_type = OP_COND_EXPR;
4229 logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR];
4230 logop->op_first = first;
585ec06d 4231 logop->op_flags = (U8)(flags | OPf_KIDS);
eb160463 4232 logop->op_private = (U8)(1 | (flags >> 8));
1a67a97c
SM		 4233 logop->op_other = LINKLIST(trueop);
4234 logop->op_next = LINKLIST(falseop);
79072805 4235
463d09e6
RGS		 4236 CHECKOP(OP_COND_EXPR, /* that's logop->op_type */
4237 logop);
79072805
LW		 4238
4239 /* establish postfix order */
1a67a97c
SM		 4240 start = LINKLIST(first);
4241 first->op_next = (OP*)logop;
79072805 4242
b1cb66bf 4243 first->op_sibling = trueop;
4244 trueop->op_sibling = falseop;
1a67a97c 4245 o = newUNOP(OP_NULL, 0, (OP*)logop);
79072805 4246
1a67a97c 4247 trueop->op_next = falseop->op_next = o;
79072805 4248
1a67a97c 4249 o->op_next = start;
11343788 4250 return o;
79072805
LW		 4251}
4252
4253OP *
864dbfa3 4254Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
79072805 4255{
27da23d5 4256 dVAR;
1a67a97c 4257 LOGOP *range;
79072805
LW		 4258 OP *flip;
4259 OP *flop;
1a67a97c 4260 OP *leftstart;
11343788 4261 OP *o;
79072805 4262
1a67a97c 4263 NewOp(1101, range, 1, LOGOP);
79072805 4264
1a67a97c
SM		 4265 range->op_type = OP_RANGE;
4266 range->op_ppaddr = PL_ppaddr[OP_RANGE];
4267 range->op_first = left;
4268 range->op_flags = OPf_KIDS;
4269 leftstart = LINKLIST(left);
4270 range->op_other = LINKLIST(right);
eb160463 4271 range->op_private = (U8)(1 | (flags >> 8));
79072805
LW		 4272
4273 left->op_sibling = right;
4274
1a67a97c
SM		 4275 range->op_next = (OP*)range;
4276 flip = newUNOP(OP_FLIP, flags, (OP*)range);
79072805 4277 flop = newUNOP(OP_FLOP, 0, flip);
11343788 4278 o = newUNOP(OP_NULL, 0, flop);
79072805 4279 linklist(flop);
1a67a97c 4280 range->op_next = leftstart;
79072805
LW		 4281
4282 left->op_next = flip;
4283 right->op_next = flop;
4284
1a67a97c
SM		 4285 range->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
4286 sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
ed6116ce 4287 flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
79072805
LW		 4288 sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
4289
4290 flip->op_private = left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
4291 flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
4292
11343788 4293 flip->op_next = o;
79072805 4294 if (!flip->op_private || !flop->op_private)
11343788 4295 linklist(o); /* blow off optimizer unless constant */
79072805 4296
11343788 4297 return o;
79072805
LW		 4298}
4299
4300OP *
864dbfa3 4301Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
79072805 4302{
97aff369 4303 dVAR;
463ee0b2 4304 OP* listop;
11343788 4305 OP* o;
73d840c0 4306 const bool once = block && block->op_flags & OPf_SPECIAL &&
a0d0e21e 4307 (block->op_type == OP_ENTERSUB || block->op_type == OP_NULL);
46c461b5
AL		 4308
4309 PERL_UNUSED_ARG(debuggable);
93a17b20 4310
463ee0b2
LW		 4311 if (expr) {
4312 if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
4313 return block; /* do {} while 0 does once */
fb73857a 4314 if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
4315 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
774d564b 4316 expr = newUNOP(OP_DEFINED, 0,
54b9620d 4317 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
55d729e4 4318 } else if (expr->op_flags & OPf_KIDS) {
46c461b5
AL		 4319 const OP * const k1 = ((UNOP*)expr)->op_first;
4320 const OP * const k2 = k1 ? k1->op_sibling : NULL;
55d729e4 4321 switch (expr->op_type) {
1c846c1f 4322 case OP_NULL:
55d729e4
GS		 4323 if (k2 && k2->op_type == OP_READLINE
4324 && (k2->op_flags & OPf_STACKED)
1c846c1f 4325 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
55d729e4 4326 expr = newUNOP(OP_DEFINED, 0, expr);
1c846c1f 4327 break;
55d729e4
GS		 4328
4329 case OP_SASSIGN:
06dc7ac6 4330 if (k1 && (k1->op_type == OP_READDIR
55d729e4 4331 || k1->op_type == OP_GLOB
6531c3e6 4332 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
06dc7ac6 4333 || k1->op_type == OP_EACH))
55d729e4
GS		 4334 expr = newUNOP(OP_DEFINED, 0, expr);
4335 break;
4336 }
774d564b 4337 }
463ee0b2 4338 }
93a17b20 4339
e1548254
RGS		 4340 /* if block is null, the next append_elem() would put UNSTACK, a scalar
4341 * op, in listop. This is wrong. [perl #27024] */
4342 if (!block)
4343 block = newOP(OP_NULL, 0);
8990e307 4344 listop = append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
883ffac3 4345 o = new_logop(OP_AND, 0, &expr, &listop);
463ee0b2 4346
883ffac3
CS		 4347 if (listop)
4348 ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
79072805 4349
11343788
MB		 4350 if (once && o != listop)
4351 o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
79072805 4352
11343788
MB		 4353 if (o == listop)
4354 o = newUNOP(OP_NULL, 0, o); /* or do {} while 1 loses outer block */
748a9306 4355
11343788
MB		 4356 o->op_flags |= flags;
4357 o = scope(o);
4358 o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
4359 return o;
79072805
LW		 4360}
4361
4362OP *
a034e688
DM		 4363Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32
4364whileline, OP *expr, OP *block, OP *cont, I32 has_my)
79072805 4365{
27da23d5 4366 dVAR;
79072805 4367 OP *redo;
c445ea15 4368 OP *next = NULL;
79072805 4369 OP *listop;
11343788 4370 OP *o;
1ba6ee2b 4371 U8 loopflags = 0;
46c461b5
AL		 4372
4373 PERL_UNUSED_ARG(debuggable);
79072805 4374
2d03de9c
AL		 4375 if (expr) {
4376 if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
4377 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
4378 expr = newUNOP(OP_DEFINED, 0,
4379 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
4380 } else if (expr->op_flags & OPf_KIDS) {
4381 const OP * const k1 = ((UNOP*)expr)->op_first;
4382 const OP * const k2 = (k1) ? k1->op_sibling : NULL;
4383 switch (expr->op_type) {
4384 case OP_NULL:
4385 if (k2 && k2->op_type == OP_READLINE
4386 && (k2->op_flags & OPf_STACKED)
4387 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
4388 expr = newUNOP(OP_DEFINED, 0, expr);
4389 break;
55d729e4 4390
2d03de9c 4391 case OP_SASSIGN:
72c8de1a 4392 if (k1 && (k1->op_type == OP_READDIR
2d03de9c
AL		 4393 || k1->op_type == OP_GLOB
4394 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
72c8de1a 4395 || k1->op_type == OP_EACH))
2d03de9c
AL		 4396 expr = newUNOP(OP_DEFINED, 0, expr);
4397 break;
4398 }
55d729e4 4399 }
748a9306 4400 }
79072805
LW		 4401
4402 if (!block)
4403 block = newOP(OP_NULL, 0);
a034e688 4404 else if (cont || has_my) {
87246558
GS		 4405 block = scope(block);
4406 }
79072805 4407
1ba6ee2b 4408 if (cont) {
79072805 4409 next = LINKLIST(cont);
1ba6ee2b 4410 }
fb73857a 4411 if (expr) {
551405c4 4412 OP * const unstack = newOP(OP_UNSTACK, 0);
85538317
GS		 4413 if (!next)
4414 next = unstack;
4415 cont = append_elem(OP_LINESEQ, cont, unstack);
fb73857a 4416 }
79072805 4417
ce3e5c45 4418 assert(block);
463ee0b2 4419 listop = append_list(OP_LINESEQ, (LISTOP*)block, (LISTOP*)cont);
ce3e5c45 4420 assert(listop);
79072805
LW		 4421 redo = LINKLIST(listop);
4422
4423 if (expr) {
eb160463 4424 PL_copline = (line_t)whileline;
883ffac3
CS		 4425 scalar(listop);
4426 o = new_logop(OP_AND, 0, &expr, &listop);
11343788 4427 if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
85e6fe83 4428 op_free(expr); /* oops, it's a while (0) */
463ee0b2 4429 op_free((OP*)loop);
5f66b61c 4430 return NULL; /* listop already freed by new_logop */
463ee0b2 4431 }
883ffac3 4432 if (listop)
497b47a8 4433 ((LISTOP*)listop)->op_last->op_next =
883ffac3 4434 (o == listop ? redo : LINKLIST(o));
79072805
LW		 4435 }
4436 else
11343788 4437 o = listop;
79072805
LW		 4438
4439 if (!loop) {
b7dc083c 4440 NewOp(1101,loop,1,LOOP);
79072805 4441 loop->op_type = OP_ENTERLOOP;
22c35a8c 4442 loop->op_ppaddr = PL_ppaddr[OP_ENTERLOOP];
79072805
LW		 4443 loop->op_private = 0;
4444 loop->op_next = (OP*)loop;
4445 }
4446
11343788 4447 o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
79072805
LW		 4448
4449 loop->op_redoop = redo;
11343788 4450 loop->op_lastop = o;
1ba6ee2b 4451 o->op_private |= loopflags;
79072805
LW		 4452
4453 if (next)
4454 loop->op_nextop = next;
4455 else
11343788 4456 loop->op_nextop = o;
79072805 4457
11343788
MB		 4458 o->op_flags |= flags;
4459 o->op_private |= (flags >> 8);
4460 return o;
79072805
LW		 4461}
4462
4463OP *
66a1b24b 4464Perl_newFOROP(pTHX_ I32 flags, char *label, line_t forline, OP *sv, OP *expr, OP *block, OP *cont)
79072805 4465{
27da23d5 4466 dVAR;
79072805 4467 LOOP *loop;
fb73857a 4468 OP *wop;
4bbc6d12 4469 PADOFFSET padoff = 0;
4633a7c4 4470 I32 iterflags = 0;
241416b8 4471 I32 iterpflags = 0;
d4c19fe8 4472 OP *madsv = NULL;
79072805 4473
79072805 4474 if (sv) {
85e6fe83 4475 if (sv->op_type == OP_RV2SV) { /* symbol table variable */
241416b8 4476 iterpflags = sv->op_private & OPpOUR_INTRO; /* for our $x () */
748a9306 4477 sv->op_type = OP_RV2GV;
22c35a8c 4478 sv->op_ppaddr = PL_ppaddr[OP_RV2GV];
0d863452
RH		 4479 if (cGVOPx_gv(cUNOPx(sv)->op_first) == PL_defgv)
4480 iterpflags |= OPpITER_DEF;
79072805 4481 }
85e6fe83 4482 else if (sv->op_type == OP_PADSV) { /* private variable */
241416b8 4483 iterpflags = sv->op_private & OPpLVAL_INTRO; /* for my $x () */
85e6fe83 4484 padoff = sv->op_targ;
eb8433b7
NC		 4485 if (PL_madskills)
4486 madsv = sv;
4487 else {
4488 sv->op_targ = 0;
4489 op_free(sv);
4490 }
5f66b61c 4491 sv = NULL;
85e6fe83 4492 }
54b9620d
MB		 4493 else if (sv->op_type == OP_THREADSV) { /* per-thread variable */
4494 padoff = sv->op_targ;
eb8433b7
NC		 4495 if (PL_madskills)
4496 madsv = sv;
4497 else {
4498 sv->op_targ = 0;
4499 iterflags |= OPf_SPECIAL;
4500 op_free(sv);
4501 }
5f66b61c 4502 sv = NULL;
54b9620d 4503 }
79072805 4504 else
cea2e8a9 4505 Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
0d863452
RH		 4506 if (padoff && strEQ(PAD_COMPNAME_PV(padoff), "$_"))
4507 iterpflags |= OPpITER_DEF;
79072805
LW		 4508 }
4509 else {
9f7d9405 4510 const PADOFFSET offset = pad_findmy("$_");
00b1698f 4511 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
aabe9514
RGS		 4512 sv = newGVOP(OP_GV, 0, PL_defgv);
4513 }
4514 else {
4515 padoff = offset;
aabe9514 4516 }
0d863452 4517 iterpflags |= OPpITER_DEF;
79072805 4518 }
5f05dabc 4519 if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
89ea2908 4520 expr = mod(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART);
4633a7c4
LW		 4521 iterflags |= OPf_STACKED;
4522 }
89ea2908
GA		 4523 else if (expr->op_type == OP_NULL &&
4524 (expr->op_flags & OPf_KIDS) &&
4525 ((BINOP*)expr)->op_first->op_type == OP_FLOP)
4526 {
4527 /* Basically turn for($x..$y) into the same as for($x,$y), but we
4528 * set the STACKED flag to indicate that these values are to be
4529 * treated as min/max values by 'pp_iterinit'.
4530 */
d4c19fe8 4531 const UNOP* const flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
551405c4 4532 LOGOP* const range = (LOGOP*) flip->op_first;
66a1b24b
AL		 4533 OP* const left = range->op_first;
4534 OP* const right = left->op_sibling;
5152d7c7 4535 LISTOP* listop;
89ea2908
GA		 4536
4537 range->op_flags &= ~OPf_KIDS;
5f66b61c 4538 range->op_first = NULL;
89ea2908 4539
5152d7c7 4540 listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
1a67a97c
SM		 4541 listop->op_first->op_next = range->op_next;
4542 left->op_next = range->op_other;
5152d7c7
GS		 4543 right->op_next = (OP*)listop;
4544 listop->op_next = listop->op_first;
89ea2908 4545
eb8433b7
NC		 4546#ifdef PERL_MAD
4547 op_getmad(expr,(OP*)listop,'O');
4548#else
89ea2908 4549 op_free(expr);
eb8433b7 4550#endif
5152d7c7 4551 expr = (OP*)(listop);
93c66552 4552 op_null(expr);
89ea2908
GA		 4553 iterflags |= OPf_STACKED;
4554 }
4555 else {
4556 expr = mod(force_list(expr), OP_GREPSTART);
4557 }
4558
4633a7c4 4559 loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
89ea2908 4560 append_elem(OP_LIST, expr, scalar(sv))));
85e6fe83 4561 assert(!loop->op_next);
241416b8 4562 /* for my $x () sets OPpLVAL_INTRO;
14f338dc 4563 * for our $x () sets OPpOUR_INTRO */
c5661c80 4564 loop->op_private = (U8)iterpflags;
b7dc083c 4565#ifdef PL_OP_SLAB_ALLOC
155aba94
GS		 4566 {
4567 LOOP *tmp;
4568 NewOp(1234,tmp,1,LOOP);
bd5f3bc4 4569 Copy(loop,tmp,1,LISTOP);
238a4c30 4570 FreeOp(loop);
155aba94
GS		 4571 loop = tmp;
4572 }
b7dc083c 4573#else
10edeb5d 4574 loop = (LOOP*)PerlMemShared_realloc(loop, sizeof(LOOP));
1c846c1f 4575#endif
85e6fe83 4576 loop->op_targ = padoff;
a034e688 4577 wop = newWHILEOP(flags, 1, loop, forline, newOP(OP_ITER, 0), block, cont, 0);
eb8433b7
NC		 4578 if (madsv)
4579 op_getmad(madsv, (OP*)loop, 'v');
3280af22 4580 PL_copline = forline;
fb73857a 4581 return newSTATEOP(0, label, wop);
79072805
LW		 4582}
4583
8990e307 4584OP*
864dbfa3 4585Perl_newLOOPEX(pTHX_ I32 type, OP *label)
8990e307 4586{
97aff369 4587 dVAR;
11343788 4588 OP *o;
2d8e6c8d 4589
8990e307 4590 if (type != OP_GOTO || label->op_type == OP_CONST) {
cdaebead
MB		 4591 /* "last()" means "last" */
4592 if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS))
4593 o = newOP(type, OPf_SPECIAL);
4594 else {
666ea192
JH		 4595 o = newPVOP(type, 0, savepv(label->op_type == OP_CONST
4596 ? SvPVx_nolen_const(((SVOP*)label)->op_sv)
4597 : ""));
cdaebead 4598 }
eb8433b7
NC		 4599#ifdef PERL_MAD
4600 op_getmad(label,o,'L');
4601#else
8990e307 4602 op_free(label);
eb8433b7 4603#endif
8990e307
LW		 4604 }
4605 else {
e3aba57a
RGS		 4606 /* Check whether it's going to be a goto &function */
4607 if (label->op_type == OP_ENTERSUB
4608 && !(label->op_flags & OPf_STACKED))
a0d0e21e 4609 label = newUNOP(OP_REFGEN, 0, mod(label, OP_REFGEN));
11343788 4610 o = newUNOP(type, OPf_STACKED, label);
8990e307 4611 }
3280af22 4612 PL_hints |= HINT_BLOCK_SCOPE;
11343788 4613 return o;
8990e307
LW		 4614}
4615
0d863452
RH		 4616/* if the condition is a literal array or hash
4617 (or @{ ... } etc), make a reference to it.
4618 */
4619STATIC OP *
4620S_ref_array_or_hash(pTHX_ OP *cond)
4621{
4622 if (cond
4623 && (cond->op_type == OP_RV2AV
4624 || cond->op_type == OP_PADAV
4625 || cond->op_type == OP_RV2HV
4626 || cond->op_type == OP_PADHV))
4627
4628 return newUNOP(OP_REFGEN,
4629 0, mod(cond, OP_REFGEN));
4630
4631 else
4632 return cond;
4633}
4634
4635/* These construct the optree fragments representing given()
4636 and when() blocks.
4637
4638 entergiven and enterwhen are LOGOPs; the op_other pointer
4639 points up to the associated leave op. We need this so we
4640 can put it in the context and make break/continue work.
4641 (Also, of course, pp_enterwhen will jump straight to
4642 op_other if the match fails.)
4643 */
4644
4645STATIC
4646OP *
4647S_newGIVWHENOP(pTHX_ OP *cond, OP *block,
4648 I32 enter_opcode, I32 leave_opcode,
4649 PADOFFSET entertarg)
4650{
97aff369 4651 dVAR;
0d863452
RH		 4652 LOGOP *enterop;
4653 OP *o;
4654
4655 NewOp(1101, enterop, 1, LOGOP);
4656 enterop->op_type = enter_opcode;
4657 enterop->op_ppaddr = PL_ppaddr[enter_opcode];
4658 enterop->op_flags = (U8) OPf_KIDS;
4659 enterop->op_targ = ((entertarg == NOT_IN_PAD) ? 0 : entertarg);
4660 enterop->op_private = 0;
4661
4662 o = newUNOP(leave_opcode, 0, (OP *) enterop);
4663
4664 if (cond) {
4665 enterop->op_first = scalar(cond);
4666 cond->op_sibling = block;
4667
4668 o->op_next = LINKLIST(cond);
4669 cond->op_next = (OP *) enterop;
4670 }
4671 else {
4672 /* This is a default {} block */
4673 enterop->op_first = block;
4674 enterop->op_flags |= OPf_SPECIAL;
4675
4676 o->op_next = (OP *) enterop;
4677 }
4678
4679 CHECKOP(enter_opcode, enterop); /* Currently does nothing, since
4680 entergiven and enterwhen both
4681 use ck_null() */
4682
4683 enterop->op_next = LINKLIST(block);
4684 block->op_next = enterop->op_other = o;
4685
4686 return o;
4687}
4688
4689/* Does this look like a boolean operation? For these purposes
4690 a boolean operation is:
4691 - a subroutine call [*]
4692 - a logical connective
4693 - a comparison operator
4694 - a filetest operator, with the exception of -s -M -A -C
4695 - defined(), exists() or eof()
4696 - /$re/ or $foo =~ /$re/
4697
4698 [*] possibly surprising
4699 */
4700STATIC
4701bool
ef519e13 4702S_looks_like_bool(pTHX_ const OP *o)
0d863452 4703{
97aff369 4704 dVAR;
0d863452
RH		 4705 switch(o->op_type) {
4706 case OP_OR:
4707 return looks_like_bool(cLOGOPo->op_first);
4708
4709 case OP_AND:
4710 return (
4711 looks_like_bool(cLOGOPo->op_first)
4712 && looks_like_bool(cLOGOPo->op_first->op_sibling));
4713
4714 case OP_ENTERSUB:
4715
4716 case OP_NOT: case OP_XOR:
4717 /* Note that OP_DOR is not here */
4718
4719 case OP_EQ: case OP_NE: case OP_LT:
4720 case OP_GT: case OP_LE: case OP_GE:
4721
4722 case OP_I_EQ: case OP_I_NE: case OP_I_LT:
4723 case OP_I_GT: case OP_I_LE: case OP_I_GE:
4724
4725 case OP_SEQ: case OP_SNE: case OP_SLT:
4726 case OP_SGT: case OP_SLE: case OP_SGE:
4727
4728 case OP_SMARTMATCH:
4729
4730 case OP_FTRREAD: case OP_FTRWRITE: case OP_FTREXEC:
4731 case OP_FTEREAD: case OP_FTEWRITE: case OP_FTEEXEC:
4732 case OP_FTIS: case OP_FTEOWNED: case OP_FTROWNED:
4733 case OP_FTZERO: case OP_FTSOCK: case OP_FTCHR:
4734 case OP_FTBLK: case OP_FTFILE: case OP_FTDIR:
4735 case OP_FTPIPE: case OP_FTLINK: case OP_FTSUID:
4736 case OP_FTSGID: case OP_FTSVTX: case OP_FTTTY:
4737 case OP_FTTEXT: case OP_FTBINARY:
4738
4739 case OP_DEFINED: case OP_EXISTS:
4740 case OP_MATCH: case OP_EOF:
4741
4742 return TRUE;
4743
4744 case OP_CONST:
4745 /* Detect comparisons that have been optimized away */
4746 if (cSVOPo->op_sv == &PL_sv_yes
4747 || cSVOPo->op_sv == &PL_sv_no)
4748
4749 return TRUE;
4750
4751 /* FALL THROUGH */
4752 default:
4753 return FALSE;
4754 }
4755}
4756
4757OP *
4758Perl_newGIVENOP(pTHX_ OP *cond, OP *block, PADOFFSET defsv_off)
4759{
97aff369 4760 dVAR;
0d863452
RH		 4761 assert( cond );
4762 return newGIVWHENOP(
4763 ref_array_or_hash(cond),
4764 block,
4765 OP_ENTERGIVEN, OP_LEAVEGIVEN,
4766 defsv_off);
4767}
4768
4769/* If cond is null, this is a default {} block */
4770OP *
4771Perl_newWHENOP(pTHX_ OP *cond, OP *block)
4772{
ef519e13 4773 const bool cond_llb = (!cond || looks_like_bool(cond));
0d863452
RH		 4774 OP *cond_op;
4775
4776 if (cond_llb)
4777 cond_op = cond;
4778 else {
4779 cond_op = newBINOP(OP_SMARTMATCH, OPf_SPECIAL,
4780 newDEFSVOP(),
4781 scalar(ref_array_or_hash(cond)));
4782 }
4783
4784 return newGIVWHENOP(
4785 cond_op,
4786 append_elem(block->op_type, block, newOP(OP_BREAK, OPf_SPECIAL)),
4787 OP_ENTERWHEN, OP_LEAVEWHEN, 0);
4788}
4789
7dafbf52
DM		 4790/*
4791=for apidoc cv_undef
4792
4793Clear out all the active components of a CV. This can happen either
4794by an explicit C<undef &foo>, or by the reference count going to zero.
4795In the former case, we keep the CvOUTSIDE pointer, so that any anonymous
4796children can still follow the full lexical scope chain.
4797
4798=cut
4799*/
4800
79072805 4801void
864dbfa3 4802Perl_cv_undef(pTHX_ CV *cv)
79072805 4803{
27da23d5 4804 dVAR;
a636914a 4805#ifdef USE_ITHREADS
aed2304a 4806 if (CvFILE(cv) && !CvISXSUB(cv)) {
35f1c1c7 4807 /* for XSUBs CvFILE point directly to static memory; __FILE__ */
a636914a 4808 Safefree(CvFILE(cv));
a636914a 4809 }
b3123a61 4810 CvFILE(cv) = NULL;
a636914a
RH		 4811#endif
4812
aed2304a 4813 if (!CvISXSUB(cv) && CvROOT(cv)) {
bb172083 4814 if (SvTYPE(cv) == SVt_PVCV && CvDEPTH(cv))
cea2e8a9 4815 Perl_croak(aTHX_ "Can't undef active subroutine");
8990e307 4816 ENTER;
a0d0e21e 4817
f3548bdc 4818 PAD_SAVE_SETNULLPAD();
a0d0e21e 4819
282f25c9 4820 op_free(CvROOT(cv));
5f66b61c
AL		 4821 CvROOT(cv) = NULL;
4822 CvSTART(cv) = NULL;
8990e307 4823 LEAVE;
79072805 4824 }
1d5db326 4825 SvPOK_off((SV*)cv); /* forget prototype */
a0714e2c 4826 CvGV(cv) = NULL;
a3985cdc
DM		 4827
4828 pad_undef(cv);
4829
7dafbf52
DM		 4830 /* remove CvOUTSIDE unless this is an undef rather than a free */
4831 if (!SvREFCNT(cv) && CvOUTSIDE(cv)) {
4832 if (!CvWEAKOUTSIDE(cv))
4833 SvREFCNT_dec(CvOUTSIDE(cv));
601f1833 4834 CvOUTSIDE(cv) = NULL;
7dafbf52 4835 }
beab0874
JT		 4836 if (CvCONST(cv)) {
4837 SvREFCNT_dec((SV*)CvXSUBANY(cv).any_ptr);
4838 CvCONST_off(cv);
4839 }
d04ba589 4840 if (CvISXSUB(cv) && CvXSUB(cv)) {
96a5add6 4841 CvXSUB(cv) = NULL;
50762d59 4842 }
7dafbf52
DM		 4843 /* delete all flags except WEAKOUTSIDE */
4844 CvFLAGS(cv) &= CVf_WEAKOUTSIDE;
79072805
LW		 4845}
4846
3fe9a6f1 4847void
cbf82dd0
NC		 4848Perl_cv_ckproto_len(pTHX_ const CV *cv, const GV *gv, const char *p,
4849 const STRLEN len)
4850{
4851 /* Can't just use a strcmp on the prototype, as CONSTSUBs "cheat" by
4852 relying on SvCUR, and doubling up the buffer to hold CvFILE(). */
4853 if (((!p != !SvPOK(cv)) /* One has prototype, one has not. */
4854 || (p && (len != SvCUR(cv) /* Not the same length. */
4855 || memNE(p, SvPVX_const(cv), len))))
4856 && ckWARN_d(WARN_PROTOTYPE)) {
2d03de9c 4857 SV* const msg = sv_newmortal();
a0714e2c 4858 SV* name = NULL;
3fe9a6f1 4859
4860 if (gv)
bd61b366 4861 gv_efullname3(name = sv_newmortal(), gv, NULL);
46fc3d4c 4862 sv_setpv(msg, "Prototype mismatch:");
4863 if (name)
95b63a38 4864 Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, (void*)name);
3fe9a6f1 4865 if (SvPOK(cv))
95b63a38 4866 Perl_sv_catpvf(aTHX_ msg, " (%"SVf")", (void*)cv);
ebe643b9 4867 else
396482e1
GA		 4868 sv_catpvs(msg, ": none");
4869 sv_catpvs(msg, " vs ");
46fc3d4c 4870 if (p)
cbf82dd0 4871 Perl_sv_catpvf(aTHX_ msg, "(%.*s)", (int) len, p);
46fc3d4c 4872 else
396482e1 4873 sv_catpvs(msg, "none");
95b63a38 4874 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%"SVf, (void*)msg);
3fe9a6f1 4875 }
4876}
4877
35f1c1c7
SB		 4878static void const_sv_xsub(pTHX_ CV* cv);
4879
beab0874 4880/*
ccfc67b7
JH		 4881
4882=head1 Optree Manipulation Functions
4883
beab0874
JT		 4884=for apidoc cv_const_sv
4885
4886If C<cv> is a constant sub eligible for inlining. returns the constant
4887value returned by the sub. Otherwise, returns NULL.
4888
4889Constant subs can be created with C<newCONSTSUB> or as described in
4890L<perlsub/"Constant Functions">.
4891
4892=cut
4893*/
760ac839 4894SV *
864dbfa3 4895Perl_cv_const_sv(pTHX_ CV *cv)
760ac839 4896{
96a5add6 4897 PERL_UNUSED_CONTEXT;
5069cc75
NC		 4898 if (!cv)
4899 return NULL;
4900 if (!(SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM))
4901 return NULL;
4902 return CvCONST(cv) ? (SV*)CvXSUBANY(cv).any_ptr : NULL;
fe5e78ed 4903}
760ac839 4904
b5c19bd7
DM		 4905/* op_const_sv: examine an optree to determine whether it's in-lineable.
4906 * Can be called in 3 ways:
4907 *
4908 * !cv
4909 * look for a single OP_CONST with attached value: return the value
4910 *
4911 * cv && CvCLONE(cv) && !CvCONST(cv)
4912 *
4913 * examine the clone prototype, and if contains only a single
4914 * OP_CONST referencing a pad const, or a single PADSV referencing
4915 * an outer lexical, return a non-zero value to indicate the CV is
4916 * a candidate for "constizing" at clone time
4917 *
4918 * cv && CvCONST(cv)
4919 *
4920 * We have just cloned an anon prototype that was marked as a const
4921 * candidiate. Try to grab the current value, and in the case of
4922 * PADSV, ignore it if it has multiple references. Return the value.
4923 */
4924
fe5e78ed 4925SV *
6867be6d 4926Perl_op_const_sv(pTHX_ const OP *o, CV *cv)
fe5e78ed 4927{
97aff369 4928 dVAR;
a0714e2c 4929 SV *sv = NULL;
fe5e78ed 4930
0f79a09d 4931 if (!o)
a0714e2c 4932 return NULL;
1c846c1f
NIS		 4933
4934 if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
fe5e78ed
GS		 4935 o = cLISTOPo->op_first->op_sibling;
4936
4937 for (; o; o = o->op_next) {
890ce7af 4938 const OPCODE type = o->op_type;
fe5e78ed 4939
1c846c1f 4940 if (sv && o->op_next == o)
fe5e78ed 4941 return sv;
e576b457
JT		 4942 if (o->op_next != o) {
4943 if (type == OP_NEXTSTATE || type == OP_NULL || type == OP_PUSHMARK)
4944 continue;
4945 if (type == OP_DBSTATE)
4946 continue;
4947 }
54310121 4948 if (type == OP_LEAVESUB || type == OP_RETURN)
4949 break;
4950 if (sv)
a0714e2c 4951 return NULL;
7766f137 4952 if (type == OP_CONST && cSVOPo->op_sv)
5dc0d613 4953 sv = cSVOPo->op_sv;
b5c19bd7 4954 else if (cv && type == OP_CONST) {
dd2155a4 4955 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
beab0874 4956 if (!sv)
a0714e2c 4957 return NULL;
b5c19bd7
DM		 4958 }
4959 else if (cv && type == OP_PADSV) {
4960 if (CvCONST(cv)) { /* newly cloned anon */
4961 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
4962 /* the candidate should have 1 ref from this pad and 1 ref
4963 * from the parent */
4964 if (!sv || SvREFCNT(sv) != 2)
a0714e2c 4965 return NULL;
beab0874 4966 sv = newSVsv(sv);
b5c19bd7
DM		 4967 SvREADONLY_on(sv);
4968 return sv;
4969 }
4970 else {
4971 if (PAD_COMPNAME_FLAGS(o->op_targ) & SVf_FAKE)
4972 sv = &PL_sv_undef; /* an arbitrary non-null value */
beab0874 4973 }
760ac839 4974 }
b5c19bd7 4975 else {
a0714e2c 4976 return NULL;
b5c19bd7 4977 }
760ac839
LW		 4978 }
4979 return sv;
4980}
4981
eb8433b7
NC		 4982#ifdef PERL_MAD
4983OP *
4984#else
09bef843 4985void
eb8433b7 4986#endif
09bef843
SB		 4987Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4988{
99129197
NC		 4989#if 0
4990 /* This would be the return value, but the return cannot be reached. */
eb8433b7
NC		 4991 OP* pegop = newOP(OP_NULL, 0);
4992#endif
4993
46c461b5
AL		 4994 PERL_UNUSED_ARG(floor);
4995
09bef843
SB		 4996 if (o)
4997 SAVEFREEOP(o);
4998 if (proto)
4999 SAVEFREEOP(proto);
5000 if (attrs)
5001 SAVEFREEOP(attrs);
5002 if (block)
5003 SAVEFREEOP(block);
5004 Perl_croak(aTHX_ "\"my sub\" not yet implemented");
eb8433b7 5005#ifdef PERL_MAD
99129197 5006 NORETURN_FUNCTION_END;
eb8433b7 5007#endif
09bef843
SB		 5008}
5009
748a9306 5010CV *
864dbfa3 5011Perl_newSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *block)
79072805 5012{
5f66b61c 5013 return Perl_newATTRSUB(aTHX_ floor, o, proto, NULL, block);
09bef843
SB		 5014}
5015
5016CV *
5017Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
5018{
27da23d5 5019 dVAR;
6867be6d 5020 const char *aname;
83ee9e09 5021 GV *gv;
5c144d81 5022 const char *ps;
ea6e9374 5023 STRLEN ps_len;
c445ea15 5024 register CV *cv = NULL;
beab0874 5025 SV *const_sv;
b48b272a
NC		 5026 /* If the subroutine has no body, no attributes, and no builtin attributes
5027 then it's just a sub declaration, and we may be able to get away with
5028 storing with a placeholder scalar in the symbol table, rather than a
5029 full GV and CV. If anything is present then it will take a full CV to
5030 store it. */
5031 const I32 gv_fetch_flags
eb8433b7
NC		 5032 = (block || attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)
5033 || PL_madskills)
b48b272a 5034 ? GV_ADDMULTI : GV_ADDMULTI | GV_NOINIT;
bd61b366 5035 const char * const name = o ? SvPVx_nolen_const(cSVOPo->op_sv) : NULL;
8e742a20
MHM		 5036
5037 if (proto) {
5038 assert(proto->op_type == OP_CONST);
5c144d81 5039 ps = SvPVx_const(((SVOP*)proto)->op_sv, ps_len);
8e742a20
MHM		 5040 }
5041 else
bd61b366 5042 ps = NULL;
8e742a20 5043
83ee9e09 5044 if (!name && PERLDB_NAMEANON && CopLINE(PL_curcop)) {
aec46f14 5045 SV * const sv = sv_newmortal();
c99da370
JH		 5046 Perl_sv_setpvf(aTHX_ sv, "%s[%s:%"IVdf"]",
5047 PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
83ee9e09 5048 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
b15aece3 5049 aname = SvPVX_const(sv);
83ee9e09
GS		 5050 }
5051 else
bd61b366 5052 aname = NULL;
61dbb99a 5053
61dbb99a 5054 gv = name ? gv_fetchsv(cSVOPo->op_sv, gv_fetch_flags, SVt_PVCV)
666ea192
JH		 5055 : gv_fetchpv(aname ? aname
5056 : (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
61dbb99a 5057 gv_fetch_flags, SVt_PVCV);
83ee9e09 5058
eb8433b7
NC		 5059 if (!PL_madskills) {
5060 if (o)
5061 SAVEFREEOP(o);
5062 if (proto)
5063 SAVEFREEOP(proto);
5064 if (attrs)
5065 SAVEFREEOP(attrs);
5066 }
3fe9a6f1 5067
09bef843 5068 if (SvTYPE(gv) != SVt_PVGV) { /* Maybe prototype now, and had at
55d729e4
GS		 5069 maximum a prototype before. */
5070 if (SvTYPE(gv) > SVt_NULL) {
0453d815 5071 if (!SvPOK((SV*)gv) && !(SvIOK((SV*)gv) && SvIVX((SV*)gv) == -1)
e476b1b5 5072 && ckWARN_d(WARN_PROTOTYPE))
f248d071 5073 {
9014280d 5074 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "Runaway prototype");
f248d071 5075 }
cbf82dd0 5076 cv_ckproto_len((CV*)gv, NULL, ps, ps_len);
55d729e4
GS		 5077 }
5078 if (ps)
ea6e9374 5079 sv_setpvn((SV*)gv, ps, ps_len);
55d729e4
GS		 5080 else
5081 sv_setiv((SV*)gv, -1);
3280af22
NIS		 5082 SvREFCNT_dec(PL_compcv);
5083 cv = PL_compcv = NULL;
5084 PL_sub_generation++;
beab0874 5085 goto done;
55d729e4
GS		 5086 }
5087
601f1833 5088 cv = (!name || GvCVGEN(gv)) ? NULL : GvCV(gv);
beab0874 5089
7fb37951
AMS		 5090#ifdef GV_UNIQUE_CHECK
5091 if (cv && GvUNIQUE(gv) && SvREADONLY(cv)) {
5092 Perl_croak(aTHX_ "Can't define subroutine %s (GV is unique)", name);
5bd07a3d
DM		 5093 }
5094#endif
5095
eb8433b7
NC		 5096 if (!block || !ps || *ps || attrs
5097 || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)
5098#ifdef PERL_MAD
5099 || block->op_type == OP_NULL
5100#endif
5101 )
a0714e2c 5102 const_sv = NULL;
beab0874 5103 else
601f1833 5104 const_sv = op_const_sv(block, NULL);
beab0874
JT		 5105
5106 if (cv) {
6867be6d 5107 const bool exists = CvROOT(cv) || CvXSUB(cv);
5bd07a3d 5108
7fb37951
AMS		 5109#ifdef GV_UNIQUE_CHECK
5110 if (exists && GvUNIQUE(gv)) {
5111 Perl_croak(aTHX_ "Can't redefine unique subroutine %s", name);
5bd07a3d
DM		 5112 }
5113#endif
5114
60ed1d8c
GS		 5115 /* if the subroutine doesn't exist and wasn't pre-declared
5116 * with a prototype, assume it will be AUTOLOADed,
5117 * skipping the prototype check
5118 */
5119 if (exists || SvPOK(cv))
cbf82dd0 5120 cv_ckproto_len(cv, gv, ps, ps_len);
68dc0745 5121 /* already defined (or promised)? */
60ed1d8c 5122 if (exists || GvASSUMECV(gv)) {
eb8433b7
NC		 5123 if ((!block
5124#ifdef PERL_MAD
5125 || block->op_type == OP_NULL
5126#endif
5127 )&& !attrs) {
d3cea301
SB		 5128 if (CvFLAGS(PL_compcv)) {
5129 /* might have had built-in attrs applied */
5130 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
5131 }
aa689395 5132 /* just a "sub foo;" when &foo is already defined */
3280af22 5133 SAVEFREESV(PL_compcv);
aa689395 5134 goto done;
5135 }
eb8433b7
NC		 5136 if (block
5137#ifdef PERL_MAD
5138 && block->op_type != OP_NULL
5139#endif
5140 ) {
beab0874
JT		 5141 if (ckWARN(WARN_REDEFINE)
5142 || (CvCONST(cv)
5143 && (!const_sv || sv_cmp(cv_const_sv(cv), const_sv))))
5144 {
6867be6d 5145 const line_t oldline = CopLINE(PL_curcop);
d8a34499
IK		 5146 if (PL_copline != NOLINE)
5147 CopLINE_set(PL_curcop, PL_copline);
9014280d 5148 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
666ea192
JH		 5149 CvCONST(cv) ? "Constant subroutine %s redefined"
5150 : "Subroutine %s redefined", name);
beab0874
JT		 5151 CopLINE_set(PL_curcop, oldline);
5152 }
eb8433b7
NC		 5153#ifdef PERL_MAD
5154 if (!PL_minus_c) /* keep old one around for madskills */
5155#endif
5156 {
5157 /* (PL_madskills unset in used file.) */
5158 SvREFCNT_dec(cv);
5159 }
601f1833 5160 cv = NULL;
79072805 5161 }
79072805
LW		 5162 }
5163 }
beab0874 5164 if (const_sv) {
f84c484e 5165 SvREFCNT_inc_simple_void_NN(const_sv);
beab0874 5166 if (cv) {
0768512c 5167 assert(!CvROOT(cv) && !CvCONST(cv));
c69006e4 5168 sv_setpvn((SV*)cv, "", 0); /* prototype is "" */
beab0874
JT		 5169 CvXSUBANY(cv).any_ptr = const_sv;
5170 CvXSUB(cv) = const_sv_xsub;
5171 CvCONST_on(cv);
d04ba589 5172 CvISXSUB_on(cv);
beab0874
JT		 5173 }
5174 else {
601f1833 5175 GvCV(gv) = NULL;
beab0874
JT		 5176 cv = newCONSTSUB(NULL, name, const_sv);
5177 }
eb8433b7
NC		 5178 PL_sub_generation++;
5179 if (PL_madskills)
5180 goto install_block;
beab0874
JT		 5181 op_free(block);
5182 SvREFCNT_dec(PL_compcv);
5183 PL_compcv = NULL;
beab0874
JT		 5184 goto done;
5185 }
09bef843
SB		 5186 if (attrs) {
5187 HV *stash;
5188 SV *rcv;
5189
5190 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>
5191 * before we clobber PL_compcv.
5192 */
99129197 5193 if (cv && (!block
eb8433b7
NC		 5194#ifdef PERL_MAD
5195 || block->op_type == OP_NULL
5196#endif
5197 )) {
09bef843 5198 rcv = (SV*)cv;
020f0e03
SB		 5199 /* Might have had built-in attributes applied -- propagate them. */
5200 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
a9164de8 5201 if (CvGV(cv) && GvSTASH(CvGV(cv)))
09bef843 5202 stash = GvSTASH(CvGV(cv));
a9164de8 5203 else if (CvSTASH(cv))
09bef843
SB		 5204 stash = CvSTASH(cv);
5205 else
5206 stash = PL_curstash;
5207 }
5208 else {
5209 /* possibly about to re-define existing subr -- ignore old cv */
5210 rcv = (SV*)PL_compcv;
a9164de8 5211 if (name && GvSTASH(gv))
09bef843
SB		 5212 stash = GvSTASH(gv);
5213 else
5214 stash = PL_curstash;
5215 }
95f0a2f1 5216 apply_attrs(stash, rcv, attrs, FALSE);
09bef843 5217 }
a0d0e21e 5218 if (cv) { /* must reuse cv if autoloaded */
eb8433b7
NC		 5219 if (
5220#ifdef PERL_MAD
5221 (
5222#endif
5223 !block
5224#ifdef PERL_MAD
5225 || block->op_type == OP_NULL) && !PL_madskills
5226#endif
5227 ) {
09bef843
SB		 5228 /* got here with just attrs -- work done, so bug out */
5229 SAVEFREESV(PL_compcv);
5230 goto done;
5231 }
a3985cdc 5232 /* transfer PL_compcv to cv */
4633a7c4 5233 cv_undef(cv);
3280af22 5234 CvFLAGS(cv) = CvFLAGS(PL_compcv);
5c41a5fa
DM		 5235 if (!CvWEAKOUTSIDE(cv))
5236 SvREFCNT_dec(CvOUTSIDE(cv));
3280af22 5237 CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
a3985cdc 5238 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv);
3280af22
NIS		 5239 CvOUTSIDE(PL_compcv) = 0;
5240 CvPADLIST(cv) = CvPADLIST(PL_compcv);
5241 CvPADLIST(PL_compcv) = 0;
282f25c9 5242 /* inner references to PL_compcv must be fixed up ... */
dd2155a4 5243 pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
282f25c9 5244 /* ... before we throw it away */
3280af22 5245 SvREFCNT_dec(PL_compcv);
b5c19bd7 5246 PL_compcv = cv;
a933f601
IZ		 5247 if (PERLDB_INTER)/* Advice debugger on the new sub. */
5248 ++PL_sub_generation;
a0d0e21e
LW		 5249 }
5250 else {
3280af22 5251 cv = PL_compcv;
44a8e56a 5252 if (name) {
5253 GvCV(gv) = cv;
eb8433b7
NC		 5254 if (PL_madskills) {
5255 if (strEQ(name, "import")) {
5256 PL_formfeed = (SV*)cv;
5257 Perl_warner(aTHX_ packWARN(WARN_VOID), "%lx\n", (long)cv);
5258 }
5259 }
44a8e56a 5260 GvCVGEN(gv) = 0;
3280af22 5261 PL_sub_generation++;
44a8e56a 5262 }
a0d0e21e 5263 }
65c50114 5264 CvGV(cv) = gv;
a636914a 5265 CvFILE_set_from_cop(cv, PL_curcop);
3280af22 5266 CvSTASH(cv) = PL_curstash;
8990e307 5267
3fe9a6f1 5268 if (ps)
ea6e9374 5269 sv_setpvn((SV*)cv, ps, ps_len);
4633a7c4 5270
3280af22 5271 if (PL_error_count) {
c07a80fd 5272 op_free(block);
5f66b61c 5273 block = NULL;
68dc0745 5274 if (name) {
6867be6d 5275 const char *s = strrchr(name, ':');
68dc0745 5276 s = s ? s+1 : name;
6d4c2119 5277 if (strEQ(s, "BEGIN")) {
e1ec3a88 5278 const char not_safe[] =
6d4c2119 5279 "BEGIN not safe after errors--compilation aborted";
faef0170 5280 if (PL_in_eval & EVAL_KEEPERR)
cea2e8a9 5281 Perl_croak(aTHX_ not_safe);
6d4c2119
CS		 5282 else {
5283 /* force display of errors found but not reported */
38a03e6e 5284 sv_catpv(ERRSV, not_safe);
95b63a38 5285 Perl_croak(aTHX_ "%"SVf, (void*)ERRSV);
6d4c2119
CS		 5286 }
5287 }
68dc0745 5288 }
c07a80fd 5289 }
eb8433b7 5290 install_block:
beab0874
JT		 5291 if (!block)
5292 goto done;
a0d0e21e 5293
7766f137 5294 if (CvLVALUE(cv)) {
78f9721b
SM		 5295 CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0,
5296 mod(scalarseq(block), OP_LEAVESUBLV));
7766f137
GS		 5297 }
5298 else {
09c2fd24
AE		 5299 /* This makes sub {}; work as expected. */
5300 if (block->op_type == OP_STUB) {
1496a290 5301 OP* const newblock = newSTATEOP(0, NULL, 0);
eb8433b7
NC		 5302#ifdef PERL_MAD
5303 op_getmad(block,newblock,'B');
5304#else
09c2fd24 5305 op_free(block);
eb8433b7
NC		 5306#endif
5307 block = newblock;
09c2fd24 5308 }
7766f137
GS		 5309 CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block));
5310 }
5311 CvROOT(cv)->op_private |= OPpREFCOUNTED;
5312 OpREFCNT_set(CvROOT(cv), 1);
5313 CvSTART(cv) = LINKLIST(CvROOT(cv));
5314 CvROOT(cv)->op_next = 0;
a2efc822 5315 CALL_PEEP(CvSTART(cv));
7766f137
GS		 5316
5317 /* now that optimizer has done its work, adjust pad values */
54310121 5318
dd2155a4
DM		 5319 pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
5320
5321 if (CvCLONE(cv)) {
beab0874
JT		 5322 assert(!CvCONST(cv));
5323 if (ps && !*ps && op_const_sv(block, cv))
5324 CvCONST_on(cv);
a0d0e21e 5325 }
79072805 5326
83ee9e09 5327 if (name || aname) {
6867be6d 5328 const char *s;
0bd48802 5329 const char * const tname = (name ? name : aname);
44a8e56a 5330
3280af22 5331 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
561b68a9 5332 SV * const sv = newSV(0);
c4420975 5333 SV * const tmpstr = sv_newmortal();
5c1737d1
NC		 5334 GV * const db_postponed = gv_fetchpvs("DB::postponed",
5335 GV_ADDMULTI, SVt_PVHV);
44a8e56a 5336 HV *hv;
5337
ed094faf
GS		 5338 Perl_sv_setpvf(aTHX_ sv, "%s:%ld-%ld",
5339 CopFILE(PL_curcop),
cc49e20b 5340 (long)PL_subline, (long)CopLINE(PL_curcop));
bd61b366 5341 gv_efullname3(tmpstr, gv, NULL);
b15aece3 5342 hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr), SvCUR(tmpstr), sv, 0);
44a8e56a 5343 hv = GvHVn(db_postponed);
551405c4
AL		 5344 if (HvFILL(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvCUR(tmpstr))) {
5345 CV * const pcv = GvCV(db_postponed);
5346 if (pcv) {
5347 dSP;
5348 PUSHMARK(SP);
5349 XPUSHs(tmpstr);
5350 PUTBACK;
5351 call_sv((SV*)pcv, G_DISCARD);
5352 }
44a8e56a 5353 }
5354 }
79072805 5355
83ee9e09 5356 if ((s = strrchr(tname,':')))
28757baa 5357 s++;
5358 else
83ee9e09 5359 s = tname;
ed094faf 5360
3c10abe3 5361 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I' && *s != 'U')
ed094faf
GS		 5362 goto done;
5363
7678c486 5364 if (strEQ(s, "BEGIN") && !PL_error_count) {
6867be6d 5365 const I32 oldscope = PL_scopestack_ix;
28757baa 5366 ENTER;
57843af0
GS		 5367 SAVECOPFILE(&PL_compiling);
5368 SAVECOPLINE(&PL_compiling);
28757baa 5369
3280af22
NIS		 5370 if (!PL_beginav)
5371 PL_beginav = newAV();
28757baa 5372 DEBUG_x( dump_sub(gv) );
ea2f84a3
GS		 5373 av_push(PL_beginav, (SV*)cv);
5374 GvCV(gv) = 0; /* cv has been hijacked */
3280af22 5375 call_list(oldscope, PL_beginav);
a6006777 5376
3280af22 5377 PL_curcop = &PL_compiling;
623e6609 5378 CopHINTS_set(&PL_compiling, PL_hints);
28757baa 5379 LEAVE;
5380 }
3280af22
NIS		 5381 else if (strEQ(s, "END") && !PL_error_count) {
5382 if (!PL_endav)
5383 PL_endav = newAV();
ed094faf 5384 DEBUG_x( dump_sub(gv) );
3280af22 5385 av_unshift(PL_endav, 1);
ea2f84a3
GS		 5386 av_store(PL_endav, 0, (SV*)cv);
5387 GvCV(gv) = 0; /* cv has been hijacked */
28757baa 5388 }
3c10abe3
AG		 5389 else if (strEQ(s, "UNITCHECK") && !PL_error_count) {
5390 /* It's never too late to run a unitcheck block */
5391 if (!PL_unitcheckav)
5392 PL_unitcheckav = newAV();
5393 DEBUG_x( dump_sub(gv) );
5394 av_unshift(PL_unitcheckav, 1);
5395 av_store(PL_unitcheckav, 0, (SV*)cv);
5396 GvCV(gv) = 0; /* cv has been hijacked */
5397 }
7d30b5c4
GS		 5398 else if (strEQ(s, "CHECK") && !PL_error_count) {
5399 if (!PL_checkav)
5400 PL_checkav = newAV();
ed094faf 5401 DEBUG_x( dump_sub(gv) );
ddda08b7 5402 if (PL_main_start && ckWARN(WARN_VOID))
9014280d 5403 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run CHECK block");
7d30b5c4 5404 av_unshift(PL_checkav, 1);
ea2f84a3
GS		 5405 av_store(PL_checkav, 0, (SV*)cv);
5406 GvCV(gv) = 0; /* cv has been hijacked */
4f25aa18 5407 }
3280af22
NIS		 5408 else if (strEQ(s, "INIT") && !PL_error_count) {
5409 if (!PL_initav)
5410 PL_initav = newAV();
ed094faf 5411 DEBUG_x( dump_sub(gv) );
ddda08b7 5412 if (PL_main_start && ckWARN(WARN_VOID))
9014280d 5413 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run INIT block");
ea2f84a3
GS		 5414 av_push(PL_initav, (SV*)cv);
5415 GvCV(gv) = 0; /* cv has been hijacked */
ae77835f 5416 }
79072805 5417 }
a6006777 5418
aa689395 5419 done:
3280af22 5420 PL_copline = NOLINE;
8990e307 5421 LEAVE_SCOPE(floor);
a0d0e21e 5422 return cv;
79072805
LW		 5423}
5424
b099ddc0 5425/* XXX unsafe for threads if eval_owner isn't held */
954c1994
GS		 5426/*
5427=for apidoc newCONSTSUB
5428
5429Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
5430eligible for inlining at compile-time.
5431
5432=cut
5433*/
5434
beab0874 5435CV *
e1ec3a88 5436Perl_newCONSTSUB(pTHX_ HV *stash, const char *name, SV *sv)
5476c433 5437{
27da23d5 5438 dVAR;
beab0874 5439 CV* cv;
cbf82dd0
NC		 5440#ifdef USE_ITHREADS
5441 const char *const temp_p = CopFILE(PL_curcop);
07fcac01 5442 const STRLEN len = temp_p ? strlen(temp_p) : 0;
cbf82dd0
NC		 5443#else
5444 SV *const temp_sv = CopFILESV(PL_curcop);
5445 STRLEN len;
5446 const char *const temp_p = temp_sv ? SvPV_const(temp_sv, len) : NULL;
5447#endif
07fcac01 5448 char *const file = savepvn(temp_p, temp_p ? len : 0);
5476c433 5449
11faa288 5450 ENTER;
11faa288 5451
f4dd75d9 5452 SAVECOPLINE(PL_curcop);
11faa288 5453 CopLINE_set(PL_curcop, PL_copline);
f4dd75d9
GS		 5454
5455 SAVEHINTS();
3280af22 5456 PL_hints &= ~HINT_BLOCK_SCOPE;
11faa288
GS		 5457
5458 if (stash) {
5459 SAVESPTR(PL_curstash);
5460 SAVECOPSTASH(PL_curcop);
5461 PL_curstash = stash;
05ec9bb3 5462 CopSTASH_set(PL_curcop,stash);
11faa288 5463 }
5476c433 5464
cbf82dd0
NC		 5465 /* file becomes the CvFILE. For an XS, it's supposed to be static storage,
5466 and so doesn't get free()d. (It's expected to be from the C pre-
5467 processor __FILE__ directive). But we need a dynamically allocated one,
77004dee
NC		 5468 and we need it to get freed. */
5469 cv = newXS_flags(name, const_sv_xsub, file, "", XS_DYNAMIC_FILENAME);
beab0874
JT		 5470 CvXSUBANY(cv).any_ptr = sv;
5471 CvCONST_on(cv);
c3db7d92 5472 Safefree(file);
5476c433 5473
65e66c80 5474#ifdef USE_ITHREADS
02f28d44
MHM		 5475 if (stash)
5476 CopSTASH_free(PL_curcop);
65e66c80 5477#endif
11faa288 5478 LEAVE;
beab0874
JT		 5479
5480 return cv;
5476c433
JD		 5481}
5482
77004dee
NC		 5483CV *
5484Perl_newXS_flags(pTHX_ const char *name, XSUBADDR_t subaddr,
5485 const char *const filename, const char *const proto,
5486 U32 flags)
5487{
5488 CV *cv = newXS(name, subaddr, filename);
5489
5490 if (flags & XS_DYNAMIC_FILENAME) {
5491 /* We need to "make arrangements" (ie cheat) to ensure that the
5492 filename lasts as long as the PVCV we just created, but also doesn't
5493 leak */
5494 STRLEN filename_len = strlen(filename);
5495 STRLEN proto_and_file_len = filename_len;
5496 char *proto_and_file;
5497 STRLEN proto_len;
5498
5499 if (proto) {
5500 proto_len = strlen(proto);
5501 proto_and_file_len += proto_len;
5502
5503 Newx(proto_and_file, proto_and_file_len + 1, char);
5504 Copy(proto, proto_and_file, proto_len, char);
5505 Copy(filename, proto_and_file + proto_len, filename_len + 1, char);
5506 } else {
5507 proto_len = 0;
5508 proto_and_file = savepvn(filename, filename_len);
5509 }
5510
5511 /* This gets free()d. :-) */
5512 sv_usepvn_flags((SV*)cv, proto_and_file, proto_and_file_len,
5513 SV_HAS_TRAILING_NUL);
5514 if (proto) {
5515 /* This gives us the correct prototype, rather than one with the
5516 file name appended. */
5517 SvCUR_set(cv, proto_len);
5518 } else {
5519 SvPOK_off(cv);
5520 }
81a2b3b6 5521 CvFILE(cv) = proto_and_file + proto_len;
77004dee
NC		 5522 } else {
5523 sv_setpv((SV *)cv, proto);
5524 }
5525 return cv;
5526}
5527
954c1994
GS		 5528/*
5529=for apidoc U||newXS
5530
77004dee
NC		 5531Used by C<xsubpp> to hook up XSUBs as Perl subs. I<filename> needs to be
5532static storage, as it is used directly as CvFILE(), without a copy being made.
954c1994
GS		 5533
5534=cut
5535*/
5536
57d3b86d 5537CV *
bfed75c6 5538Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename)
a0d0e21e 5539{
97aff369 5540 dVAR;
666ea192
JH		 5541 GV * const gv = gv_fetchpv(name ? name :
5542 (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
5543 GV_ADDMULTI, SVt_PVCV);
79072805 5544 register CV *cv;
44a8e56a 5545
1ecdd9a8
HS		 5546 if (!subaddr)
5547 Perl_croak(aTHX_ "panic: no address for '%s' in '%s'", name, filename);
5548
601f1833 5549 if ((cv = (name ? GvCV(gv) : NULL))) {
44a8e56a 5550 if (GvCVGEN(gv)) {
5551 /* just a cached method */
5552 SvREFCNT_dec(cv);
601f1833 5553 cv = NULL;
44a8e56a 5554 }
5555 else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
5556 /* already defined (or promised) */
1df70142 5557 /* XXX It's possible for this HvNAME_get to return null, and get passed into strEQ */
66a1b24b
AL		 5558 if (ckWARN(WARN_REDEFINE)) {
5559 GV * const gvcv = CvGV(cv);
5560 if (gvcv) {
5561 HV * const stash = GvSTASH(gvcv);
5562 if (stash) {
8b38226b
AL		 5563 const char *redefined_name = HvNAME_get(stash);
5564 if ( strEQ(redefined_name,"autouse") ) {
66a1b24b
AL		 5565 const line_t oldline = CopLINE(PL_curcop);
5566 if (PL_copline != NOLINE)
5567 CopLINE_set(PL_curcop, PL_copline);
5568 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
666ea192
JH		 5569 CvCONST(cv) ? "Constant subroutine %s redefined"
5570 : "Subroutine %s redefined"
5571 ,name);
66a1b24b
AL		 5572 CopLINE_set(PL_curcop, oldline);
5573 }
5574 }
5575 }
a0d0e21e
LW		 5576 }
5577 SvREFCNT_dec(cv);
601f1833 5578 cv = NULL;
79072805 5579 }
79072805 5580 }
44a8e56a 5581
5582 if (cv) /* must reuse cv if autoloaded */
5583 cv_undef(cv);
a0d0e21e 5584 else {
561b68a9 5585 cv = (CV*)newSV(0);
a0d0e21e 5586 sv_upgrade((SV *)cv, SVt_PVCV);
44a8e56a 5587 if (name) {
5588 GvCV(gv) = cv;
5589 GvCVGEN(gv) = 0;
3280af22 5590 PL_sub_generation++;
44a8e56a 5591 }
a0d0e21e 5592 }
65c50114 5593 CvGV(cv) = gv;
b195d487 5594 (void)gv_fetchfile(filename);
dd374669 5595 CvFILE(cv) = (char *)filename; /* NOTE: not copied, as it is expected to be
57843af0 5596 an external constant string */
d04ba589 5597 CvISXSUB_on(cv);
a0d0e21e 5598 CvXSUB(cv) = subaddr;
44a8e56a 5599
28757baa 5600 if (name) {
e1ec3a88 5601 const char *s = strrchr(name,':');
28757baa 5602 if (s)
5603 s++;
5604 else
5605 s = name;
ed094faf 5606
7d30b5c4 5607 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
ed094faf
GS		 5608 goto done;
5609
28757baa 5610 if (strEQ(s, "BEGIN")) {
3280af22
NIS		 5611 if (!PL_beginav)
5612 PL_beginav = newAV();
ea2f84a3
GS		 5613 av_push(PL_beginav, (SV*)cv);
5614 GvCV(gv) = 0; /* cv has been hijacked */
28757baa 5615 }
5616 else if (strEQ(s, "END")) {
3280af22
NIS		 5617 if (!PL_endav)
5618 PL_endav = newAV();
5619 av_unshift(PL_endav, 1);
ea2f84a3
GS		 5620 av_store(PL_endav, 0, (SV*)cv);
5621 GvCV(gv) = 0; /* cv has been hijacked */
28757baa 5622 }
7d30b5c4
GS		 5623 else if (strEQ(s, "CHECK")) {
5624 if (!PL_checkav)
5625 PL_checkav = newAV();
ddda08b7 5626 if (PL_main_start && ckWARN(WARN_VOID))
9014280d 5627 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run CHECK block");
7d30b5c4 5628 av_unshift(PL_checkav, 1);
ea2f84a3
GS		 5629 av_store(PL_checkav, 0, (SV*)cv);
5630 GvCV(gv) = 0; /* cv has been hijacked */
4f25aa18 5631 }
7d07dbc2 5632 else if (strEQ(s, "INIT")) {
3280af22
NIS		 5633 if (!PL_initav)
5634 PL_initav = newAV();
ddda08b7 5635 if (PL_main_start && ckWARN(WARN_VOID))
9014280d 5636 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run INIT block");
ea2f84a3
GS		 5637 av_push(PL_initav, (SV*)cv);
5638 GvCV(gv) = 0; /* cv has been hijacked */
ae77835f 5639 }
28757baa 5640 }
8990e307 5641 else
a5f75d66 5642 CvANON_on(cv);
44a8e56a 5643
ed094faf 5644done:
a0d0e21e 5645 return cv;
79072805
LW		 5646}
5647
eb8433b7
NC		 5648#ifdef PERL_MAD
5649OP *
5650#else
79072805 5651void
eb8433b7 5652#endif
864dbfa3 5653Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
79072805 5654{
97aff369 5655 dVAR;
79072805 5656 register CV *cv;
eb8433b7
NC		 5657#ifdef PERL_MAD
5658 OP* pegop = newOP(OP_NULL, 0);
5659#endif
79072805 5660
0bd48802 5661 GV * const gv = o
f776e3cd 5662 ? gv_fetchsv(cSVOPo->op_sv, GV_ADD, SVt_PVFM)
fafc274c 5663 : gv_fetchpvs("STDOUT", GV_ADD|GV_NOTQUAL, SVt_PVFM);
0bd48802 5664
7fb37951
AMS		 5665#ifdef GV_UNIQUE_CHECK
5666 if (GvUNIQUE(gv)) {
666ea192 5667 Perl_croak(aTHX_ "Bad symbol for form (GV is unique)");
5bd07a3d
DM		 5668 }
5669#endif
a5f75d66 5670 GvMULTI_on(gv);
155aba94 5671 if ((cv = GvFORM(gv))) {
599cee73 5672 if (ckWARN(WARN_REDEFINE)) {
6867be6d 5673 const line_t oldline = CopLINE(PL_curcop);
d8a34499
IK		 5674 if (PL_copline != NOLINE)
5675 CopLINE_set(PL_curcop, PL_copline);
7a5fd60d 5676 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
666ea192
JH		 5677 o ? "Format %"SVf" redefined"
5678 : "Format STDOUT redefined", (void*)cSVOPo->op_sv);
57843af0 5679 CopLINE_set(PL_curcop, oldline);
79072805 5680 }
8990e307 5681 SvREFCNT_dec(cv);
79072805 5682 }
3280af22 5683 cv = PL_compcv;
79072805 5684 GvFORM(gv) = cv;
65c50114 5685 CvGV(cv) = gv;
a636914a 5686 CvFILE_set_from_cop(cv, PL_curcop);
79072805 5687
a0d0e21e 5688
dd2155a4 5689 pad_tidy(padtidy_FORMAT);
79072805 5690 CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
7934575e
GS		 5691 CvROOT(cv)->op_private |= OPpREFCOUNTED;
5692 OpREFCNT_set(CvROOT(cv), 1);
79072805
LW		 5693 CvSTART(cv) = LINKLIST(CvROOT(cv));
5694 CvROOT(cv)->op_next = 0;
a2efc822 5695 CALL_PEEP(CvSTART(cv));
eb8433b7
NC		 5696#ifdef PERL_MAD
5697 op_getmad(o,pegop,'n');
5698 op_getmad_weak(block, pegop, 'b');
5699#else
11343788 5700 op_free(o);
eb8433b7 5701#endif
3280af22 5702 PL_copline = NOLINE;
8990e307 5703 LEAVE_SCOPE(floor);
eb8433b7
NC		 5704#ifdef PERL_MAD
5705 return pegop;
5706#endif
79072805
LW		 5707}
5708
5709OP *
864dbfa3 5710Perl_newANONLIST(pTHX_ OP *o)
79072805 5711{
78c72037 5712 return convert(OP_ANONLIST, OPf_SPECIAL, o);
79072805
LW		 5713}
5714
5715OP *
864dbfa3 5716Perl_newANONHASH(pTHX_ OP *o)
79072805 5717{
78c72037 5718 return convert(OP_ANONHASH, OPf_SPECIAL, o);
a0d0e21e
LW		 5719}
5720
5721OP *
864dbfa3 5722Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
a0d0e21e 5723{
5f66b61c 5724 return newANONATTRSUB(floor, proto, NULL, block);
09bef843
SB		 5725}
5726
5727OP *
5728Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
5729{
a0d0e21e 5730 return newUNOP(OP_REFGEN, 0,
09bef843
SB		 5731 newSVOP(OP_ANONCODE, 0,
5732 (SV*)newATTRSUB(floor, 0, proto, attrs, block)));
79072805
LW		 5733}
5734
5735OP *
864dbfa3 5736Perl_oopsAV(pTHX_ OP *o)
79072805 5737{
27da23d5 5738 dVAR;
ed6116ce
LW		 5739 switch (o->op_type) {
5740 case OP_PADSV:
5741 o->op_type = OP_PADAV;
22c35a8c 5742 o->op_ppaddr = PL_ppaddr[OP_PADAV];
51e247a3 5743 return ref(o, OP_RV2AV);
b2ffa427 5744
ed6116ce 5745 case OP_RV2SV:
79072805 5746 o->op_type = OP_RV2AV;
22c35a8c 5747 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
79072805 5748 ref(o, OP_RV2AV);
ed6116ce
LW		 5749 break;
5750
5751 default:
0453d815 5752 if (ckWARN_d(WARN_INTERNAL))
9014280d 5753 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
ed6116ce
LW		 5754 break;
5755 }
79072805
LW		 5756 return o;
5757}
5758
5759OP *
864dbfa3 5760Perl_oopsHV(pTHX_ OP *o)
79072805 5761{
27da23d5 5762 dVAR;
ed6116ce
LW		 5763 switch (o->op_type) {
5764 case OP_PADSV:
5765 case OP_PADAV:
5766 o->op_type = OP_PADHV;
22c35a8c 5767 o->op_ppaddr = PL_ppaddr[OP_PADHV];
51e247a3 5768 return ref(o, OP_RV2HV);
ed6116ce
LW		 5769
5770 case OP_RV2SV:
5771 case OP_RV2AV:
79072805 5772 o->op_type = OP_RV2HV;
22c35a8c 5773 o->op_ppaddr = PL_ppaddr[OP_RV2HV];
79072805 5774 ref(o, OP_RV2HV);
ed6116ce
LW		 5775 break;
5776
5777 default:
0453d815 5778 if (ckWARN_d(WARN_INTERNAL))
9014280d 5779 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV");
ed6116ce
LW		 5780 break;
5781 }
79072805
LW		 5782 return o;
5783}
5784
5785OP *
864dbfa3 5786Perl_newAVREF(pTHX_ OP *o)
79072805 5787{
27da23d5 5788 dVAR;
ed6116ce
LW		 5789 if (o->op_type == OP_PADANY) {
5790 o->op_type = OP_PADAV;
22c35a8c 5791 o->op_ppaddr = PL_ppaddr[OP_PADAV];
93a17b20 5792 return o;
ed6116ce 5793 }
a1063b2d 5794 else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)
9014280d
PM		 5795 && ckWARN(WARN_DEPRECATED)) {
5796 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
a1063b2d
RH		 5797 "Using an array as a reference is deprecated");
5798 }
79072805
LW		 5799 return newUNOP(OP_RV2AV, 0, scalar(o));
5800}
5801
5802OP *
864dbfa3 5803Perl_newGVREF(pTHX_ I32 type, OP *o)
79072805 5804{
82092f1d 5805 if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
a0d0e21e 5806 return newUNOP(OP_NULL, 0, o);
748a9306 5807 return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
79072805
LW		 5808}
5809
5810OP *
864dbfa3 5811Perl_newHVREF(pTHX_ OP *o)
79072805 5812{
27da23d5 5813 dVAR;
ed6116ce
LW		 5814 if (o->op_type == OP_PADANY) {
5815 o->op_type = OP_PADHV;
22c35a8c 5816 o->op_ppaddr = PL_ppaddr[OP_PADHV];
93a17b20 5817 return o;
ed6116ce 5818 }
a1063b2d 5819 else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)
9014280d
PM		 5820 && ckWARN(WARN_DEPRECATED)) {
5821 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
a1063b2d
RH		 5822 "Using a hash as a reference is deprecated");
5823 }
79072805
LW		 5824 return newUNOP(OP_RV2HV, 0, scalar(o));
5825}
5826
5827OP *
864dbfa3 5828Perl_newCVREF(pTHX_ I32 flags, OP *o)
79072805 5829{
c07a80fd 5830 return newUNOP(OP_RV2CV, flags, scalar(o));
79072805
LW		 5831}
5832
5833OP *
864dbfa3 5834Perl_newSVREF(pTHX_ OP *o)
79072805 5835{
27da23d5 5836 dVAR;
ed6116ce
LW		 5837 if (o->op_type == OP_PADANY) {
5838 o->op_type = OP_PADSV;
22c35a8c 5839 o->op_ppaddr = PL_ppaddr[OP_PADSV];
93a17b20 5840 return o;
ed6116ce 5841 }
224a4551
MB		 5842 else if (o->op_type == OP_THREADSV && !(o->op_flags & OPpDONE_SVREF)) {
5843 o->op_flags |= OPpDONE_SVREF;
a863c7d1 5844 return o;
224a4551 5845 }
79072805
LW		 5846 return newUNOP(OP_RV2SV, 0, scalar(o));
5847}
5848
61b743bb
DM		 5849/* Check routines. See the comments at the top of this file for details
5850 * on when these are called */
79072805
LW		 5851
5852OP *
cea2e8a9 5853Perl_ck_anoncode(pTHX_ OP *o)
5f05dabc 5854{
dd2155a4 5855 cSVOPo->op_targ = pad_add_anon(cSVOPo->op_sv, o->op_type);
eb8433b7 5856 if (!PL_madskills)
1d866c12 5857 cSVOPo->op_sv = NULL;
5dc0d613 5858 return o;
5f05dabc 5859}
5860
5861OP *
cea2e8a9 5862Perl_ck_bitop(pTHX_ OP *o)
55497cff 5863{
97aff369 5864 dVAR;
276b2a0c
RGS		 5865#define OP_IS_NUMCOMPARE(op) \
5866 ((op) == OP_LT || (op) == OP_I_LT || \
5867 (op) == OP_GT || (op) == OP_I_GT || \
5868 (op) == OP_LE || (op) == OP_I_LE || \
5869 (op) == OP_GE || (op) == OP_I_GE || \
5870 (op) == OP_EQ || (op) == OP_I_EQ || \
5871 (op) == OP_NE || (op) == OP_I_NE || \
5872 (op) == OP_NCMP || (op) == OP_I_NCMP)
d5ec2987 5873 o->op_private = (U8)(PL_hints & HINT_INTEGER);
2b84528b
RGS		 5874 if (!(o->op_flags & OPf_STACKED) /* Not an assignment */
5875 && (o->op_type == OP_BIT_OR
5876 || o->op_type == OP_BIT_AND
5877 || o->op_type == OP_BIT_XOR))
276b2a0c 5878 {
1df70142
AL		 5879 const OP * const left = cBINOPo->op_first;
5880 const OP * const right = left->op_sibling;
96a925ab
YST		 5881 if ((OP_IS_NUMCOMPARE(left->op_type) &&
5882 (left->op_flags & OPf_PARENS) == 0) ||
5883 (OP_IS_NUMCOMPARE(right->op_type) &&
5884 (right->op_flags & OPf_PARENS) == 0))
276b2a0c
RGS		 5885 if (ckWARN(WARN_PRECEDENCE))
5886 Perl_warner(aTHX_ packWARN(WARN_PRECEDENCE),
5887 "Possible precedence problem on bitwise %c operator",
5888 o->op_type == OP_BIT_OR ? '|'
5889 : o->op_type == OP_BIT_AND ? '&' : '^'
5890 );
5891 }
5dc0d613 5892 return o;
55497cff 5893}
5894
5895OP *
cea2e8a9 5896Perl_ck_concat(pTHX_ OP *o)
79072805 5897{
0bd48802 5898 const OP * const kid = cUNOPo->op_first;
96a5add6 5899 PERL_UNUSED_CONTEXT;
df91b2c5
AE		 5900 if (kid->op_type == OP_CONCAT && !(kid->op_private & OPpTARGET_MY) &&
5901 !(kUNOP->op_first->op_flags & OPf_MOD))
0165acc7 5902 o->op_flags |= OPf_STACKED;
11343788 5903 return o;
79072805
LW		 5904}
5905
5906OP *
cea2e8a9 5907Perl_ck_spair(pTHX_ OP *o)
79072805 5908{
27da23d5 5909 dVAR;
11343788 5910 if (o->op_flags & OPf_KIDS) {
79072805 5911 OP* newop;
a0d0e21e 5912 OP* kid;
6867be6d 5913 const OPCODE type = o->op_type;
5dc0d613 5914 o = modkids(ck_fun(o), type);
11343788 5915 kid = cUNOPo->op_first;
a0d0e21e 5916 newop = kUNOP->op_first->op_sibling;
1496a290
AL		 5917 if (newop) {
5918 const OPCODE type = newop->op_type;
5919 if (newop->op_sibling || !(PL_opargs[type] & OA_RETSCALAR) ||
5920 type == OP_PADAV || type == OP_PADHV ||
5921 type == OP_RV2AV || type == OP_RV2HV)
5922 return o;
a0d0e21e 5923 }
eb8433b7
NC		 5924#ifdef PERL_MAD
5925 op_getmad(kUNOP->op_first,newop,'K');
5926#else
a0d0e21e 5927 op_free(kUNOP->op_first);
eb8433b7 5928#endif
a0d0e21e
LW		 5929 kUNOP->op_first = newop;
5930 }
22c35a8c 5931 o->op_ppaddr = PL_ppaddr[++o->op_type];
11343788 5932 return ck_fun(o);
a0d0e21e
LW		 5933}
5934
5935OP *
cea2e8a9 5936Perl_ck_delete(pTHX_ OP *o)
a0d0e21e 5937{
11343788 5938 o = ck_fun(o);
5dc0d613 5939 o->op_private = 0;
11343788 5940 if (o->op_flags & OPf_KIDS) {
551405c4 5941 OP * const kid = cUNOPo->op_first;
01020589
GS		 5942 switch (kid->op_type) {
5943 case OP_ASLICE:
5944 o->op_flags |= OPf_SPECIAL;
5945 /* FALL THROUGH */
5946 case OP_HSLICE:
5dc0d613 5947 o->op_private |= OPpSLICE;
01020589
GS		 5948 break;
5949 case OP_AELEM:
5950 o->op_flags |= OPf_SPECIAL;
5951 /* FALL THROUGH */
5952 case OP_HELEM:
5953 break;
5954 default:
5955 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
53e06cf0 5956 OP_DESC(o));
01020589 5957 }
93c66552 5958 op_null(kid);
79072805 5959 }
11343788 5960 return o;
79072805
LW		 5961}
5962
5963OP *
96e176bf
CL		 5964Perl_ck_die(pTHX_ OP *o)
5965{
5966#ifdef VMS
5967 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
5968#endif
5969 return ck_fun(o);
5970}
5971
5972OP *
cea2e8a9 5973Perl_ck_eof(pTHX_ OP *o)
79072805 5974{
97aff369 5975 dVAR;
79072805 5976
11343788
MB		 5977 if (o->op_flags & OPf_KIDS) {
5978 if (cLISTOPo->op_first->op_type == OP_STUB) {
1d866c12
AL		 5979 OP * const newop
5980 = newUNOP(o->op_type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv));
eb8433b7
NC		 5981#ifdef PERL_MAD
5982 op_getmad(o,newop,'O');
5983#else
11343788 5984 op_free(o);
eb8433b7
NC		 5985#endif
5986 o = newop;
8990e307 5987 }
11343788 5988 return ck_fun(o);
79072805 5989 }
11343788 5990 return o;
79072805
LW		 5991}
5992
5993OP *
cea2e8a9 5994Perl_ck_eval(pTHX_ OP *o)
79072805 5995{
27da23d5 5996 dVAR;
3280af22 5997 PL_hints |= HINT_BLOCK_SCOPE;
11343788 5998 if (o->op_flags & OPf_KIDS) {
46c461b5 5999 SVOP * const kid = (SVOP*)cUNOPo->op_first;
79072805 6000
93a17b20 6001 if (!kid) {
11343788 6002 o->op_flags &= ~OPf_KIDS;
93c66552 6003 op_null(o);
79072805 6004 }
b14574b4 6005 else if (kid->op_type == OP_LINESEQ || kid->op_type == OP_STUB) {
79072805 6006 LOGOP *enter;
eb8433b7 6007#ifdef PERL_MAD
1d866c12 6008 OP* const oldo = o;
eb8433b7 6009#endif
79072805 6010
11343788 6011 cUNOPo->op_first = 0;
eb8433b7 6012#ifndef PERL_MAD
11343788 6013 op_free(o);
eb8433b7 6014#endif
79072805 6015
b7dc083c 6016 NewOp(1101, enter, 1, LOGOP);
79072805 6017 enter->op_type = OP_ENTERTRY;
22c35a8c 6018 enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
79072805
LW		 6019 enter->op_private = 0;
6020
6021 /* establish postfix order */
6022 enter->op_next = (OP*)enter;
6023
11343788
MB		 6024 o = prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
6025 o->op_type = OP_LEAVETRY;
22c35a8c 6026 o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
11343788 6027 enter->op_other = o;
eb8433b7 6028 op_getmad(oldo,o,'O');
11343788 6029 return o;
79072805 6030 }
b5c19bd7 6031 else {
473986ff 6032 scalar((OP*)kid);
b5c19bd7
DM		 6033 PL_cv_has_eval = 1;
6034 }
79072805
LW		 6035 }
6036 else {
eb8433b7 6037#ifdef PERL_MAD
1d866c12 6038 OP* const oldo = o;
eb8433b7 6039#else
11343788 6040 op_free(o);
eb8433b7 6041#endif
54b9620d 6042 o = newUNOP(OP_ENTEREVAL, 0, newDEFSVOP());
eb8433b7 6043 op_getmad(oldo,o,'O');
79072805 6044 }
3280af22 6045 o->op_targ = (PADOFFSET)PL_hints;
7168684c 6046 if ((PL_hints & HINT_LOCALIZE_HH) != 0 && GvHV(PL_hintgv)) {
0d863452 6047 /* Store a copy of %^H that pp_entereval can pick up */
5b9c0671
NC		 6048 OP *hhop = newSVOP(OP_CONST, 0,
6049 (SV*)Perl_hv_copy_hints_hv(aTHX_ GvHV(PL_hintgv)));
0d863452
RH		 6050 cUNOPo->op_first->op_sibling = hhop;
6051 o->op_private |= OPpEVAL_HAS_HH;
6052 }
11343788 6053 return o;
79072805
LW		 6054}
6055
6056OP *
d98f61e7
GS		 6057Perl_ck_exit(pTHX_ OP *o)
6058{
6059#ifdef VMS
551405c4 6060 HV * const table = GvHV(PL_hintgv);
d98f61e7 6061 if (table) {
a4fc7abc 6062 SV * const * const svp = hv_fetchs(table, "vmsish_exit", FALSE);
d98f61e7
GS		 6063 if (svp && *svp && SvTRUE(*svp))
6064 o->op_private |= OPpEXIT_VMSISH;
6065 }
96e176bf 6066 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
d98f61e7
GS		 6067#endif
6068 return ck_fun(o);
6069}
6070
6071OP *
cea2e8a9 6072Perl_ck_exec(pTHX_ OP *o)
79072805 6073{
11343788 6074 if (o->op_flags & OPf_STACKED) {
6867be6d 6075 OP *kid;
11343788
MB		 6076 o = ck_fun(o);
6077 kid = cUNOPo->op_first->op_sibling;
8990e307 6078 if (kid->op_type == OP_RV2GV)
93c66552 6079 op_null(kid);
79072805 6080 }
463ee0b2 6081 else
11343788
MB		 6082 o = listkids(o);
6083 return o;
79072805
LW		 6084}
6085
6086OP *
cea2e8a9 6087Perl_ck_exists(pTHX_ OP *o)
5f05dabc 6088{
97aff369 6089 dVAR;
5196be3e
MB		 6090 o = ck_fun(o);
6091 if (o->op_flags & OPf_KIDS) {
46c461b5 6092 OP * const kid = cUNOPo->op_first;
afebc493
GS		 6093 if (kid->op_type == OP_ENTERSUB) {
6094 (void) ref(kid, o->op_type);
6095 if (kid->op_type != OP_RV2CV && !PL_error_count)
6096 Perl_croak(aTHX_ "%s argument is not a subroutine name",
53e06cf0 6097 OP_DESC(o));
afebc493
GS		 6098 o->op_private |= OPpEXISTS_SUB;
6099 }
6100 else if (kid->op_type == OP_AELEM)
01020589
GS		 6101 o->op_flags |= OPf_SPECIAL;
6102 else if (kid->op_type != OP_HELEM)
6103 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element",
53e06cf0 6104 OP_DESC(o));
93c66552 6105 op_null(kid);
5f05dabc 6106 }
5196be3e 6107 return o;
5f05dabc 6108}
6109
79072805 6110OP *
cea2e8a9 6111Perl_ck_rvconst(pTHX_ register OP *o)
79072805 6112{
27da23d5 6113 dVAR;
0bd48802 6114 SVOP * const kid = (SVOP*)cUNOPo->op_first;
85e6fe83 6115
3280af22 6116 o->op_private |= (PL_hints & HINT_STRICT_REFS);
e26df76a
NC		 6117 if (o->op_type == OP_RV2CV)
6118 o->op_private &= ~1;
6119
79072805 6120 if (kid->op_type == OP_CONST) {
44a8e56a 6121 int iscv;
6122 GV *gv;
504618e9 6123 SV * const kidsv = kid->op_sv;
44a8e56a 6124
779c5bc9
GS		 6125 /* Is it a constant from cv_const_sv()? */
6126 if (SvROK(kidsv) && SvREADONLY(kidsv)) {
0bd48802 6127 SV * const rsv = SvRV(kidsv);
42d0e0b7 6128 const svtype type = SvTYPE(rsv);
bd61b366 6129 const char *badtype = NULL;
779c5bc9
GS		 6130
6131 switch (o->op_type) {
6132 case OP_RV2SV:
42d0e0b7 6133 if (type > SVt_PVMG)
779c5bc9
GS		 6134 badtype = "a SCALAR";
6135 break;
6136 case OP_RV2AV:
42d0e0b7 6137 if (type != SVt_PVAV)
779c5bc9
GS		 6138 badtype = "an ARRAY";
6139 break;
6140 case OP_RV2HV:
42d0e0b7 6141 if (type != SVt_PVHV)
779c5bc9 6142 badtype = "a HASH";
779c5bc9
GS		 6143 break;
6144 case OP_RV2CV:
42d0e0b7 6145 if (type != SVt_PVCV)
779c5bc9
GS		 6146 badtype = "a CODE";
6147 break;
6148 }
6149 if (badtype)
cea2e8a9 6150 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
779c5bc9
GS		 6151 return o;
6152 }
ce10b5d1
RGS		 6153 else if ((o->op_type == OP_RV2HV || o->op_type == OP_RV2SV) &&
6154 (PL_hints & HINT_STRICT_REFS) && SvPOK(kidsv)) {
6155 /* If this is an access to a stash, disable "strict refs", because
6156 * stashes aren't auto-vivified at compile-time (unless we store
6157 * symbols in them), and we don't want to produce a run-time
6158 * stricture error when auto-vivifying the stash. */
6159 const char *s = SvPV_nolen(kidsv);
6160 const STRLEN l = SvCUR(kidsv);
6161 if (l > 1 && s[l-1] == ':' && s[l-2] == ':')
6162 o->op_private &= ~HINT_STRICT_REFS;
6163 }
6164 if ((o->op_private & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
5f66b61c 6165 const char *badthing;
5dc0d613 6166 switch (o->op_type) {
44a8e56a 6167 case OP_RV2SV:
6168 badthing = "a SCALAR";
6169 break;
6170 case OP_RV2AV:
6171 badthing = "an ARRAY";
6172 break;
6173 case OP_RV2HV:
6174 badthing = "a HASH";
6175 break;
5f66b61c
AL		 6176 default:
6177 badthing = NULL;
6178 break;
44a8e56a 6179 }
6180 if (badthing)
1c846c1f 6181 Perl_croak(aTHX_
95b63a38
JH		 6182 "Can't use bareword (\"%"SVf"\") as %s ref while \"strict refs\" in use",
6183 (void*)kidsv, badthing);
44a8e56a 6184 }
93233ece
CS		 6185 /*
6186 * This is a little tricky. We only want to add the symbol if we
6187 * didn't add it in the lexer. Otherwise we get duplicate strict
6188 * warnings. But if we didn't add it in the lexer, we must at
6189 * least pretend like we wanted to add it even if it existed before,
6190 * or we get possible typo warnings. OPpCONST_ENTERED says
6191 * whether the lexer already added THIS instance of this symbol.
6192 */
5196be3e 6193 iscv = (o->op_type == OP_RV2CV) * 2;
93233ece 6194 do {
7a5fd60d 6195 gv = gv_fetchsv(kidsv,
748a9306 6196 iscv | !(kid->op_private & OPpCONST_ENTERED),
a0d0e21e
LW		 6197 iscv
6198 ? SVt_PVCV
11343788 6199 : o->op_type == OP_RV2SV
a0d0e21e 6200 ? SVt_PV
11343788 6201 : o->op_type == OP_RV2AV
a0d0e21e 6202 ? SVt_PVAV
11343788 6203 : o->op_type == OP_RV2HV
a0d0e21e
LW		 6204 ? SVt_PVHV
6205 : SVt_PVGV);
93233ece
CS		 6206 } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
6207 if (gv) {
6208 kid->op_type = OP_GV;
6209 SvREFCNT_dec(kid->op_sv);
350de78d 6210#ifdef USE_ITHREADS
638eceb6 6211 /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
350de78d 6212 kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
dd2155a4 6213 SvREFCNT_dec(PAD_SVl(kPADOP->op_padix));
743e66e6 6214 GvIN_PAD_on(gv);
b37c2d43 6215 PAD_SETSV(kPADOP->op_padix, (SV*) SvREFCNT_inc_simple_NN(gv));
350de78d 6216#else
b37c2d43 6217 kid->op_sv = SvREFCNT_inc_simple_NN(gv);
350de78d 6218#endif
23f1ca44 6219 kid->op_private = 0;
76cd736e 6220 kid->op_ppaddr = PL_ppaddr[OP_GV];
a0d0e21e 6221 }
79072805 6222 }
11343788 6223 return o;
79072805
LW		 6224}
6225
6226OP *
cea2e8a9 6227Perl_ck_ftst(pTHX_ OP *o)
79072805 6228{
27da23d5 6229 dVAR;
6867be6d 6230 const I32 type = o->op_type;
79072805 6231
d0dca557 6232 if (o->op_flags & OPf_REF) {
6f207bd3 6233 NOOP;
d0dca557
JD		 6234 }
6235 else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
551405c4 6236 SVOP * const kid = (SVOP*)cUNOPo->op_first;
1496a290 6237 const OPCODE kidtype = kid->op_type;
79072805 6238
1496a290 6239 if (kidtype == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
551405c4 6240 OP * const newop = newGVOP(type, OPf_REF,
f776e3cd 6241 gv_fetchsv(kid->op_sv, GV_ADD, SVt_PVIO));
eb8433b7
NC		 6242#ifdef PERL_MAD
6243 op_getmad(o,newop,'O');
6244#else
11343788 6245 op_free(o);
eb8433b7 6246#endif
1d866c12 6247 return newop;
79072805 6248 }
1d866c12 6249 if ((PL_hints & HINT_FILETEST_ACCESS) && OP_IS_FILETEST_ACCESS(o))
1af34c76 6250 o->op_private |= OPpFT_ACCESS;
1496a290
AL		 6251 if (PL_check[kidtype] == MEMBER_TO_FPTR(Perl_ck_ftst)
6252 && kidtype != OP_STAT && kidtype != OP_LSTAT)
fbb0b3b3 6253 o->op_private |= OPpFT_STACKED;
79072805
LW		 6254 }
6255 else {
eb8433b7 6256#ifdef PERL_MAD
1d866c12 6257 OP* const oldo = o;
eb8433b7 6258#else
11343788 6259 op_free(o);
eb8433b7 6260#endif
79072805 6261 if (type == OP_FTTTY)
8fde6460 6262 o = newGVOP(type, OPf_REF, PL_stdingv);
79072805 6263 else
d0dca557 6264 o = newUNOP(type, 0, newDEFSVOP());
eb8433b7 6265 op_getmad(oldo,o,'O');
79072805 6266 }
11343788 6267 return o;
79072805
LW		 6268}
6269
6270OP *
cea2e8a9 6271Perl_ck_fun(pTHX_ OP *o)
79072805 6272{
97aff369 6273 dVAR;
6867be6d 6274 const int type = o->op_type;
22c35a8c 6275 register I32 oa = PL_opargs[type] >> OASHIFT;
aeea060c 6276
11343788 6277 if (o->op_flags & OPf_STACKED) {
79072805
LW		 6278 if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
6279 oa &= ~OA_OPTIONAL;
6280 else
11343788 6281 return no_fh_allowed(o);
79072805
LW		 6282 }
6283
11343788 6284 if (o->op_flags & OPf_KIDS) {
6867be6d
AL		 6285 OP **tokid = &cLISTOPo->op_first;
6286 register OP *kid = cLISTOPo->op_first;
6287 OP *sibl;
6288 I32 numargs = 0;
6289
8990e307 6290 if (kid->op_type == OP_PUSHMARK ||
155aba94 6291 (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
8990e307 6292 {
79072805
LW		 6293 tokid = &kid->op_sibling;
6294 kid = kid->op_sibling;
6295 }
22c35a8c 6296 if (!kid && PL_opargs[type] & OA_DEFGV)
54b9620d 6297 *tokid = kid = newDEFSVOP();
79072805
LW		 6298
6299 while (oa && kid) {
6300 numargs++;
6301 sibl = kid->op_sibling;
eb8433b7
NC		 6302#ifdef PERL_MAD
6303 if (!sibl && kid->op_type == OP_STUB) {
6304 numargs--;
6305 break;
6306 }
6307#endif
79072805
LW		 6308 switch (oa & 7) {
6309 case OA_SCALAR:
62c18ce2
GS		 6310 /* list seen where single (scalar) arg expected? */
6311 if (numargs == 1 && !(oa >> 4)
6312 && kid->op_type == OP_LIST && type != OP_SCALAR)
6313 {
6314 return too_many_arguments(o,PL_op_desc[type]);
6315 }
79072805
LW		 6316 scalar(kid);
6317 break;
6318 case OA_LIST:
6319 if (oa < 16) {
6320 kid = 0;
6321 continue;
6322 }
6323 else
6324 list(kid);
6325 break;
6326 case OA_AVREF:
936edb8b 6327 if ((type == OP_PUSH || type == OP_UNSHIFT)
f87c3213 6328 && !kid->op_sibling && ckWARN(WARN_SYNTAX))
9014280d 6329 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
de4864e4 6330 "Useless use of %s with no values",
936edb8b 6331 PL_op_desc[type]);
b2ffa427 6332
79072805 6333 if (kid->op_type == OP_CONST &&
62c18ce2
GS		 6334 (kid->op_private & OPpCONST_BARE))
6335 {
551405c4 6336 OP * const newop = newAVREF(newGVOP(OP_GV, 0,
f776e3cd 6337 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVAV) ));
12bcd1a6
PM		 6338 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
6339 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
7a5fd60d 6340 "Array @%"SVf" missing the @ in argument %"IVdf" of %s()",
95b63a38 6341 (void*)((SVOP*)kid)->op_sv, (IV)numargs, PL_op_desc[type]);
eb8433b7
NC		 6342#ifdef PERL_MAD
6343 op_getmad(kid,newop,'K');
6344#else
79072805 6345 op_free(kid);
eb8433b7 6346#endif
79072805
LW		 6347 kid = newop;
6348 kid->op_sibling = sibl;
6349 *tokid = kid;
6350 }
8990e307 6351 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV)
35cd451c 6352 bad_type(numargs, "array", PL_op_desc[type], kid);
a0d0e21e 6353 mod(kid, type);
79072805
LW		 6354 break;
6355 case OA_HVREF:
6356 if (kid->op_type == OP_CONST &&
62c18ce2
GS		 6357 (kid->op_private & OPpCONST_BARE))
6358 {
551405c4 6359 OP * const newop = newHVREF(newGVOP(OP_GV, 0,
f776e3cd 6360 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVHV) ));
12bcd1a6
PM		 6361 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
6362 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
7a5fd60d 6363 "Hash %%%"SVf" missing the %% in argument %"IVdf" of %s()",
95b63a38 6364 (void*)((SVOP*)kid)->op_sv, (IV)numargs, PL_op_desc[type]);
eb8433b7
NC		 6365#ifdef PERL_MAD
6366 op_getmad(kid,newop,'K');
6367#else
79072805 6368 op_free(kid);
eb8433b7 6369#endif
79072805
LW		 6370 kid = newop;
6371 kid->op_sibling = sibl;
6372 *tokid = kid;
6373 }
8990e307 6374 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
35cd451c 6375 bad_type(numargs, "hash", PL_op_desc[type], kid);
a0d0e21e 6376 mod(kid, type);
79072805
LW		 6377 break;
6378 case OA_CVREF:
6379 {
551405c4 6380 OP * const newop = newUNOP(OP_NULL, 0, kid);
79072805
LW		 6381 kid->op_sibling = 0;
6382 linklist(kid);
6383 newop->op_next = newop;
6384 kid = newop;
6385 kid->op_sibling = sibl;
6386 *tokid = kid;
6387 }
6388 break;
6389 case OA_FILEREF:
c340be78 6390 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
79072805 6391 if (kid->op_type == OP_CONST &&
62c18ce2
GS		 6392 (kid->op_private & OPpCONST_BARE))
6393 {
0bd48802 6394 OP * const newop = newGVOP(OP_GV, 0,
f776e3cd 6395 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVIO));
afbdacea 6396 if (!(o->op_private & 1) && /* if not unop */
8a996ce8 6397 kid == cLISTOPo->op_last)
364daeac 6398 cLISTOPo->op_last = newop;
eb8433b7
NC		 6399#ifdef PERL_MAD
6400 op_getmad(kid,newop,'K');
6401#else
79072805 6402 op_free(kid);
eb8433b7 6403#endif
79072805
LW		 6404 kid = newop;
6405 }
1ea32a52
GS		 6406 else if (kid->op_type == OP_READLINE) {
6407 /* neophyte patrol: open(<FH>), close(<FH>) etc. */
53e06cf0 6408 bad_type(numargs, "HANDLE", OP_DESC(o), kid);
1ea32a52 6409 }
79072805 6410 else {
35cd451c 6411 I32 flags = OPf_SPECIAL;
a6c40364 6412 I32 priv = 0;
2c8ac474
GS		 6413 PADOFFSET targ = 0;
6414
35cd451c 6415 /* is this op a FH constructor? */
853846ea 6416 if (is_handle_constructor(o,numargs)) {
bd61b366 6417 const char *name = NULL;
dd2155a4 6418 STRLEN len = 0;
2c8ac474
GS		 6419
6420 flags = 0;
6421 /* Set a flag to tell rv2gv to vivify
853846ea
NIS		 6422 * need to "prove" flag does not mean something
6423 * else already - NI-S 1999/05/07
2c8ac474
GS		 6424 */
6425 priv = OPpDEREF;
6426 if (kid->op_type == OP_PADSV) {
dd2155a4
DM		 6427 name = PAD_COMPNAME_PV(kid->op_targ);
6428 /* SvCUR of a pad namesv can't be trusted
6429 * (see PL_generation), so calc its length
6430 * manually */
6431 if (name)
6432 len = strlen(name);
6433
2c8ac474
GS		 6434 }
6435 else if (kid->op_type == OP_RV2SV
6436 && kUNOP->op_first->op_type == OP_GV)
6437 {
0bd48802 6438 GV * const gv = cGVOPx_gv(kUNOP->op_first);
2c8ac474
GS		 6439 name = GvNAME(gv);
6440 len = GvNAMELEN(gv);
6441 }
afd1915d
GS		 6442 else if (kid->op_type == OP_AELEM
6443 || kid->op_type == OP_HELEM)
6444 {
735fec84 6445 OP *firstop;
551405c4 6446 OP *op = ((BINOP*)kid)->op_first;
a4fc7abc 6447 name = NULL;
551405c4 6448 if (op) {
a0714e2c 6449 SV *tmpstr = NULL;
551405c4 6450 const char * const a =
666ea192
JH		 6451 kid->op_type == OP_AELEM ?
6452 "[]" : "{}";
0c4b0a3f
JH		 6453 if (((op->op_type == OP_RV2AV) ||
6454 (op->op_type == OP_RV2HV)) &&
735fec84
RGS		 6455 (firstop = ((UNOP*)op)->op_first) &&
6456 (firstop->op_type == OP_GV)) {
0c4b0a3f 6457 /* packagevar $a[] or $h{} */
735fec84 6458 GV * const gv = cGVOPx_gv(firstop);
0c4b0a3f
JH		 6459 if (gv)
6460 tmpstr =
6461 Perl_newSVpvf(aTHX_
6462 "%s%c...%c",
6463 GvNAME(gv),
6464 a[0], a[1]);
6465 }
6466 else if (op->op_type == OP_PADAV
6467 || op->op_type == OP_PADHV) {
6468 /* lexicalvar $a[] or $h{} */
551405c4 6469 const char * const padname =
0c4b0a3f
JH		 6470 PAD_COMPNAME_PV(op->op_targ);
6471 if (padname)
6472 tmpstr =
6473 Perl_newSVpvf(aTHX_
6474 "%s%c...%c",
6475 padname + 1,
6476 a[0], a[1]);
0c4b0a3f
JH		 6477 }
6478 if (tmpstr) {
93524f2b 6479 name = SvPV_const(tmpstr, len);
0c4b0a3f
JH		 6480 sv_2mortal(tmpstr);
6481 }
6482 }
6483 if (!name) {
6484 name = "__ANONIO__";
6485 len = 10;
6486 }
6487 mod(kid, type);
afd1915d 6488 }
2c8ac474
GS		 6489 if (name) {
6490 SV *namesv;
6491 targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
dd2155a4 6492 namesv = PAD_SVl(targ);
862a34c6 6493 SvUPGRADE(namesv, SVt_PV);
2c8ac474
GS		 6494 if (*name != '$')
6495 sv_setpvn(namesv, "$", 1);
6496 sv_catpvn(namesv, name, len);
6497 }
853846ea 6498 }
79072805 6499 kid->op_sibling = 0;
35cd451c 6500 kid = newUNOP(OP_RV2GV, flags, scalar(kid));
2c8ac474
GS		 6501 kid->op_targ = targ;
6502 kid->op_private |= priv;
79072805
LW		 6503 }
6504 kid->op_sibling = sibl;
6505 *tokid = kid;
6506 }
6507 scalar(kid);
6508 break;
6509 case OA_SCALARREF:
a0d0e21e 6510 mod(scalar(kid), type);
79072805
LW		 6511 break;
6512 }
6513 oa >>= 4;
6514 tokid = &kid->op_sibling;
6515 kid = kid->op_sibling;
6516 }
eb8433b7
NC		 6517#ifdef PERL_MAD
6518 if (kid && kid->op_type != OP_STUB)
6519 return too_many_arguments(o,OP_DESC(o));
6520 o->op_private |= numargs;
6521#else
6522 /* FIXME - should the numargs move as for the PERL_MAD case? */
11343788 6523 o->op_private |= numargs;
79072805 6524 if (kid)
53e06cf0 6525 return too_many_arguments(o,OP_DESC(o));
eb8433b7 6526#endif
11343788 6527 listkids(o);
79072805 6528 }
22c35a8c 6529 else if (PL_opargs[type] & OA_DEFGV) {
c56915e3 6530#ifdef PERL_MAD
c7fe699d 6531 OP *newop = newUNOP(type, 0, newDEFSVOP());
c56915e3 6532 op_getmad(o,newop,'O');
c7fe699d 6533 return newop;
c56915e3 6534#else
c7fe699d 6535 /* Ordering of these two is important to keep f_map.t passing. */
11343788 6536 op_free(o);
c7fe699d 6537 return newUNOP(type, 0, newDEFSVOP());
c56915e3 6538#endif
a0d0e21e
LW		 6539 }
6540
79072805
LW		 6541 if (oa) {
6542 while (oa & OA_OPTIONAL)
6543 oa >>= 4;
6544 if (oa && oa != OA_LIST)
53e06cf0 6545 return too_few_arguments(o,OP_DESC(o));
79072805 6546 }
11343788 6547 return o;
79072805
LW		 6548}
6549
6550OP *
cea2e8a9 6551Perl_ck_glob(pTHX_ OP *o)
79072805 6552{
27da23d5 6553 dVAR;
fb73857a 6554 GV *gv;
6555
649da076 6556 o = ck_fun(o);
1f2bfc8a 6557 if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
54b9620d 6558 append_elem(OP_GLOB, o, newDEFSVOP());
fb73857a 6559
fafc274c 6560 if (!((gv = gv_fetchpvs("glob", GV_NOTQUAL, SVt_PVCV))
b9f751c0
GS		 6561 && GvCVu(gv) && GvIMPORTED_CV(gv)))
6562 {
5c1737d1 6563 gv = gv_fetchpvs("CORE::GLOBAL::glob", 0, SVt_PVCV);
b9f751c0 6564 }
b1cb66bf 6565
52bb0670 6566#if !defined(PERL_EXTERNAL_GLOB)
72b16652 6567 /* XXX this can be tightened up and made more failsafe. */
f444d496 6568 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
7d3fb230 6569 GV *glob_gv;
72b16652 6570 ENTER;
00ca71c1 6571 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
a0714e2c 6572 newSVpvs("File::Glob"), NULL, NULL, NULL);
5c1737d1
NC		 6573 gv = gv_fetchpvs("CORE::GLOBAL::glob", 0, SVt_PVCV);
6574 glob_gv = gv_fetchpvs("File::Glob::csh_glob", 0, SVt_PVCV);
7d3fb230 6575 GvCV(gv) = GvCV(glob_gv);
b37c2d43 6576 SvREFCNT_inc_void((SV*)GvCV(gv));
7d3fb230 6577 GvIMPORTED_CV_on(gv);
72b16652
GS		 6578 LEAVE;
6579 }
52bb0670 6580#endif /* PERL_EXTERNAL_GLOB */
72b16652 6581
b9f751c0 6582 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
5196be3e 6583 append_elem(OP_GLOB, o,
80252599 6584 newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
1f2bfc8a 6585 o->op_type = OP_LIST;
22c35a8c 6586 o->op_ppaddr = PL_ppaddr[OP_LIST];
1f2bfc8a 6587 cLISTOPo->op_first->op_type = OP_PUSHMARK;
22c35a8c 6588 cLISTOPo->op_first->op_ppaddr = PL_ppaddr[OP_PUSHMARK];
ad33f57d 6589 cLISTOPo->op_first->op_targ = 0;
1f2bfc8a 6590 o = newUNOP(OP_ENTERSUB, OPf_STACKED,
aeea060c 6591 append_elem(OP_LIST, o,
1f2bfc8a
MB		 6592 scalar(newUNOP(OP_RV2CV, 0,
6593 newGVOP(OP_GV, 0, gv)))));
d58bf5aa
MB		 6594 o = newUNOP(OP_NULL, 0, ck_subr(o));
6595 o->op_targ = OP_GLOB; /* hint at what it used to be */
6596 return o;
b1cb66bf 6597 }
6598 gv = newGVgen("main");
a0d0e21e 6599 gv_IOadd(gv);
11343788
MB		 6600 append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
6601 scalarkids(o);
649da076 6602 return o;
79072805
LW		 6603}
6604
6605OP *
cea2e8a9 6606Perl_ck_grep(pTHX_ OP *o)
79072805 6607{
27da23d5 6608 dVAR;
03ca120d 6609 LOGOP *gwop = NULL;
79072805 6610 OP *kid;
6867be6d 6611 const OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
9f7d9405 6612 PADOFFSET offset;
79072805 6613
22c35a8c 6614 o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
03ca120d 6615 /* don't allocate gwop here, as we may leak it if PL_error_count > 0 */
aeea060c 6616
11343788 6617 if (o->op_flags & OPf_STACKED) {
a0d0e21e 6618 OP* k;
11343788
MB		 6619 o = ck_sort(o);
6620 kid = cLISTOPo->op_first->op_sibling;
d09ad856
BS		 6621 if (!cUNOPx(kid)->op_next)
6622 Perl_croak(aTHX_ "panic: ck_grep");
e3c9a8b9 6623 for (k = cUNOPx(kid)->op_first; k; k = k->op_next) {
a0d0e21e
LW		 6624 kid = k;
6625 }
03ca120d 6626 NewOp(1101, gwop, 1, LOGOP);
a0d0e21e 6627 kid->op_next = (OP*)gwop;
11343788 6628 o->op_flags &= ~OPf_STACKED;
93a17b20 6629 }
11343788 6630 kid = cLISTOPo->op_first->op_sibling;
a0d0e21e
LW		 6631 if (type == OP_MAPWHILE)
6632 list(kid);
6633 else
6634 scalar(kid);
11343788 6635 o = ck_fun(o);
3280af22 6636 if (PL_error_count)
11343788 6637 return o;
aeea060c 6638 kid = cLISTOPo->op_first->op_sibling;
79072805 6639 if (kid->op_type != OP_NULL)
cea2e8a9 6640 Perl_croak(aTHX_ "panic: ck_grep");
79072805
LW		 6641 kid = kUNOP->op_first;
6642
03ca120d
MHM		 6643 if (!gwop)
6644 NewOp(1101, gwop, 1, LOGOP);
a0d0e21e 6645 gwop->op_type = type;
22c35a8c 6646 gwop->op_ppaddr = PL_ppaddr[type];
11343788 6647 gwop->op_first = listkids(o);
79072805 6648 gwop->op_flags |= OPf_KIDS;
79072805 6649 gwop->op_other = LINKLIST(kid);
79072805 6650 kid->op_next = (OP*)gwop;
59f00321 6651 offset = pad_findmy("$_");
00b1698f 6652 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
59f00321
RGS		 6653 o->op_private = gwop->op_private = 0;
6654 gwop->op_targ = pad_alloc(type, SVs_PADTMP);
6655 }
6656 else {
6657 o->op_private = gwop->op_private = OPpGREP_LEX;
6658 gwop->op_targ = o->op_targ = offset;
6659 }
79072805 6660
11343788 6661 kid = cLISTOPo->op_first->op_sibling;
a0d0e21e 6662 if (!kid || !kid->op_sibling)
53e06cf0 6663 return too_few_arguments(o,OP_DESC(o));
a0d0e21e
LW		 6664 for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
6665 mod(kid, OP_GREPSTART);
6666
79072805
LW		 6667 return (OP*)gwop;
6668}
6669
6670OP *
cea2e8a9 6671Perl_ck_index(pTHX_ OP *o)
79072805 6672{
11343788
MB		 6673 if (o->op_flags & OPf_KIDS) {
6674 OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
0b71040e
LW		 6675 if (kid)
6676 kid = kid->op_sibling; /* get past "big" */
79072805 6677 if (kid && kid->op_type == OP_CONST)
2779dcf1 6678 fbm_compile(((SVOP*)kid)->op_sv, 0);
79072805 6679 }
11343788 6680 return ck_fun(o);
79072805
LW		 6681}
6682
6683OP *
cea2e8a9 6684Perl_ck_lengthconst(pTHX_ OP *o)
79072805
LW		 6685{
6686 /* XXX length optimization goes here */
11343788 6687 return ck_fun(o);
79072805
LW		 6688}
6689
6690OP *
cea2e8a9 6691Perl_ck_lfun(pTHX_ OP *o)
79072805 6692{
6867be6d 6693 const OPCODE type = o->op_type;
5dc0d613 6694 return modkids(ck_fun(o), type);
79072805
LW		 6695}
6696
6697OP *
cea2e8a9 6698Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */
69794302 6699{
12bcd1a6 6700 if ((o->op_flags & OPf_KIDS) && ckWARN2(WARN_DEPRECATED, WARN_SYNTAX)) {
d0334bed
GS		 6701 switch (cUNOPo->op_first->op_type) {
6702 case OP_RV2AV:
a8739d98
JH		 6703 /* This is needed for
6704 if (defined %stash::)
6705 to work. Do not break Tk.
6706 */
1c846c1f 6707 break; /* Globals via GV can be undef */
d0334bed
GS		 6708 case OP_PADAV:
6709 case OP_AASSIGN: /* Is this a good idea? */
12bcd1a6 6710 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
f10b0346 6711 "defined(@array) is deprecated");
12bcd1a6 6712 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
cc507455 6713 "\t(Maybe you should just omit the defined()?)\n");
69794302 6714 break;
d0334bed 6715 case OP_RV2HV:
a8739d98
JH		 6716 /* This is needed for
6717 if (defined %stash::)
6718 to work. Do not break Tk.
6719 */
1c846c1f 6720 break; /* Globals via GV can be undef */
d0334bed 6721 case OP_PADHV:
12bcd1a6 6722 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
894356b3 6723 "defined(%%hash) is deprecated");
12bcd1a6 6724 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
cc507455 6725 "\t(Maybe you should just omit the defined()?)\n");
d0334bed
GS		 6726 break;
6727 default:
6728 /* no warning */
6729 break;
6730 }
69794302
MJD		 6731 }
6732 return ck_rfun(o);
6733}
6734
6735OP *
cea2e8a9 6736Perl_ck_rfun(pTHX_ OP *o)
8990e307 6737{
6867be6d 6738 const OPCODE type = o->op_type;
5dc0d613 6739 return refkids(ck_fun(o), type);
8990e307
LW		 6740}
6741
6742OP *
cea2e8a9 6743Perl_ck_listiob(pTHX_ OP *o)
79072805
LW		 6744{
6745 register OP *kid;
aeea060c 6746
11343788 6747 kid = cLISTOPo->op_first;
79072805 6748 if (!kid) {
11343788
MB		 6749 o = force_list(o);
6750 kid = cLISTOPo->op_first;
79072805
LW		 6751 }
6752 if (kid->op_type == OP_PUSHMARK)
6753 kid = kid->op_sibling;
11343788 6754 if (kid && o->op_flags & OPf_STACKED)
79072805
LW		 6755 kid = kid->op_sibling;
6756 else if (kid && !kid->op_sibling) { /* print HANDLE; */
6757 if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
11343788 6758 o->op_flags |= OPf_STACKED; /* make it a filehandle */
748a9306 6759 kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
11343788
MB		 6760 cLISTOPo->op_first->op_sibling = kid;
6761 cLISTOPo->op_last = kid;
79072805
LW		 6762 kid = kid->op_sibling;
6763 }
6764 }
b2ffa427 6765
79072805 6766 if (!kid)
54b9620d 6767 append_elem(o->op_type, o, newDEFSVOP());
79072805 6768
2de3dbcc 6769 return listkids(o);
bbce6d69 6770}
6771
6772OP *
0d863452
RH		 6773Perl_ck_smartmatch(pTHX_ OP *o)
6774{
97aff369 6775 dVAR;
0d863452
RH		 6776 if (0 == (o->op_flags & OPf_SPECIAL)) {
6777 OP *first = cBINOPo->op_first;
6778 OP *second = first->op_sibling;
6779
6780 /* Implicitly take a reference to an array or hash */
5f66b61c 6781 first->op_sibling = NULL;
0d863452
RH		 6782 first = cBINOPo->op_first = ref_array_or_hash(first);
6783 second = first->op_sibling = ref_array_or_hash(second);
6784
6785 /* Implicitly take a reference to a regular expression */
6786 if (first->op_type == OP_MATCH) {
6787 first->op_type = OP_QR;
6788 first->op_ppaddr = PL_ppaddr[OP_QR];
6789 }
6790 if (second->op_type == OP_MATCH) {
6791 second->op_type = OP_QR;
6792 second->op_ppaddr = PL_ppaddr[OP_QR];
6793 }
6794 }
6795
6796 return o;
6797}
6798
6799
6800OP *
b162f9ea
IZ		 6801Perl_ck_sassign(pTHX_ OP *o)
6802{
1496a290 6803 OP * const kid = cLISTOPo->op_first;
b162f9ea
IZ		 6804 /* has a disposable target? */
6805 if ((PL_opargs[kid->op_type] & OA_TARGLEX)
6b66af17
GS		 6806 && !(kid->op_flags & OPf_STACKED)
6807 /* Cannot steal the second time! */
6808 && !(kid->op_private & OPpTARGET_MY))
b162f9ea 6809 {
551405c4 6810 OP * const kkid = kid->op_sibling;
b162f9ea
IZ		 6811
6812 /* Can just relocate the target. */
2c2d71f5
JH		 6813 if (kkid && kkid->op_type == OP_PADSV
6814 && !(kkid->op_private & OPpLVAL_INTRO))
6815 {
b162f9ea 6816 kid->op_targ = kkid->op_targ;
743e66e6 6817 kkid->op_targ = 0;
b162f9ea
IZ		 6818 /* Now we do not need PADSV and SASSIGN. */
6819 kid->op_sibling = o->op_sibling; /* NULL */
6820 cLISTOPo->op_first = NULL;
eb8433b7
NC		 6821#ifdef PERL_MAD
6822 op_getmad(o,kid,'O');
6823 op_getmad(kkid,kid,'M');
6824#else
b162f9ea
IZ		 6825 op_free(o);
6826 op_free(kkid);
eb8433b7 6827#endif
b162f9ea
IZ		 6828 kid->op_private |= OPpTARGET_MY; /* Used for context settings */
6829 return kid;
6830 }
6831 }
952306ac
RGS		 6832 if (kid->op_sibling) {
6833 OP *kkid = kid->op_sibling;
6834 if (kkid->op_type == OP_PADSV
6835 && (kkid->op_private & OPpLVAL_INTRO)
6836 && SvPAD_STATE(*av_fetch(PL_comppad_name, kkid->op_targ, FALSE))) {
6837 o->op_private |= OPpASSIGN_STATE;
6838 /* hijacking PADSTALE for uninitialized state variables */
6839 SvPADSTALE_on(PAD_SVl(kkid->op_targ));
6840 }
6841 }
b162f9ea
IZ		 6842 return o;
6843}
6844
6845OP *
cea2e8a9 6846Perl_ck_match(pTHX_ OP *o)
79072805 6847{
97aff369 6848 dVAR;
0d863452 6849 if (o->op_type != OP_QR && PL_compcv) {
9f7d9405 6850 const PADOFFSET offset = pad_findmy("$_");
00b1698f 6851 if (offset != NOT_IN_PAD && !(PAD_COMPNAME_FLAGS_isOUR(offset))) {
59f00321
RGS		 6852 o->op_targ = offset;
6853 o->op_private |= OPpTARGET_MY;
6854 }
6855 }
6856 if (o->op_type == OP_MATCH || o->op_type == OP_QR)
6857 o->op_private |= OPpRUNTIME;
11343788 6858 return o;
79072805
LW		 6859}
6860
6861OP *
f5d5a27c
CS		 6862Perl_ck_method(pTHX_ OP *o)
6863{
551405c4 6864 OP * const kid = cUNOPo->op_first;
f5d5a27c
CS		 6865 if (kid->op_type == OP_CONST) {
6866 SV* sv = kSVOP->op_sv;
a4fc7abc
AL		 6867 const char * const method = SvPVX_const(sv);
6868 if (!(strchr(method, ':') || strchr(method, '\''))) {
f5d5a27c 6869 OP *cmop;
1c846c1f 6870 if (!SvREADONLY(sv) || !SvFAKE(sv)) {
a4fc7abc 6871 sv = newSVpvn_share(method, SvCUR(sv), 0);
1c846c1f
NIS		 6872 }
6873 else {
a0714e2c 6874 kSVOP->op_sv = NULL;
1c846c1f 6875 }
f5d5a27c 6876 cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
eb8433b7
NC		 6877#ifdef PERL_MAD
6878 op_getmad(o,cmop,'O');
6879#else
f5d5a27c 6880 op_free(o);
eb8433b7 6881#endif
f5d5a27c
CS		 6882 return cmop;
6883 }
6884 }
6885 return o;
6886}
6887
6888OP *
cea2e8a9 6889Perl_ck_null(pTHX_ OP *o)
79072805 6890{
96a5add6 6891 PERL_UNUSED_CONTEXT;
11343788 6892 return o;
79072805
LW		 6893}
6894
6895OP *
16fe6d59
GS		 6896Perl_ck_open(pTHX_ OP *o)
6897{
97aff369 6898 dVAR;
551405c4 6899 HV * const table = GvHV(PL_hintgv);
16fe6d59 6900 if (table) {
a4fc7abc 6901 SV **svp = hv_fetchs(table, "open_IN", FALSE);
16fe6d59 6902 if (svp && *svp) {
551405c4 6903 const I32 mode = mode_from_discipline(*svp);
16fe6d59
GS		 6904 if (mode & O_BINARY)
6905 o->op_private |= OPpOPEN_IN_RAW;
6906 else if (mode & O_TEXT)
6907 o->op_private |= OPpOPEN_IN_CRLF;
6908 }
6909
a4fc7abc 6910 svp = hv_fetchs(table, "open_OUT", FALSE);
16fe6d59 6911 if (svp && *svp) {
551405c4 6912 const I32 mode = mode_from_discipline(*svp);
16fe6d59
GS		 6913 if (mode & O_BINARY)
6914 o->op_private |= OPpOPEN_OUT_RAW;
6915 else if (mode & O_TEXT)
6916 o->op_private |= OPpOPEN_OUT_CRLF;
6917 }
6918 }
6919 if (o->op_type == OP_BACKTICK)
6920 return o;
3b82e551
JH		 6921 {
6922 /* In case of three-arg dup open remove strictness
6923 * from the last arg if it is a bareword. */
551405c4
AL		 6924 OP * const first = cLISTOPx(o)->op_first; /* The pushmark. */
6925 OP * const last = cLISTOPx(o)->op_last; /* The bareword. */
3b82e551 6926 OP *oa;
b15aece3 6927 const char *mode;
3b82e551
JH		 6928
6929 if ((last->op_type == OP_CONST) && /* The bareword. */
6930 (last->op_private & OPpCONST_BARE) &&
6931 (last->op_private & OPpCONST_STRICT) &&
6932 (oa = first->op_sibling) && /* The fh. */
6933 (oa = oa->op_sibling) && /* The mode. */
ea1d064a 6934 (oa->op_type == OP_CONST) &&
3b82e551 6935 SvPOK(((SVOP*)oa)->op_sv) &&
b15aece3 6936 (mode = SvPVX_const(((SVOP*)oa)->op_sv)) &&
3b82e551
JH		 6937 mode[0] == '>' && mode[1] == '&' && /* A dup open. */
6938 (last == oa->op_sibling)) /* The bareword. */
6939 last->op_private &= ~OPpCONST_STRICT;
6940 }
16fe6d59
GS		 6941 return ck_fun(o);
6942}
6943
6944OP *
cea2e8a9 6945Perl_ck_repeat(pTHX_ OP *o)
79072805 6946{
11343788
MB		 6947 if (cBINOPo->op_first->op_flags & OPf_PARENS) {
6948 o->op_private |= OPpREPEAT_DOLIST;
6949 cBINOPo->op_first = force_list(cBINOPo->op_first);
79072805
LW		 6950 }
6951 else
11343788
MB		 6952 scalar(o);
6953 return o;
79072805
LW		 6954}
6955
6956OP *
cea2e8a9 6957Perl_ck_require(pTHX_ OP *o)
8990e307 6958{
97aff369 6959 dVAR;
a0714e2c 6960 GV* gv = NULL;
ec4ab249 6961
11343788 6962 if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
551405c4 6963 SVOP * const kid = (SVOP*)cUNOPo->op_first;
8990e307
LW		 6964
6965 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
551405c4 6966 SV * const sv = kid->op_sv;
5c144d81 6967 U32 was_readonly = SvREADONLY(sv);
8990e307 6968 char *s;
5c144d81
NC		 6969
6970 if (was_readonly) {
6971 if (SvFAKE(sv)) {
6972 sv_force_normal_flags(sv, 0);
6973 assert(!SvREADONLY(sv));
6974 was_readonly = 0;
6975 } else {
6976 SvREADONLY_off(sv);
6977 }
6978 }
6979
6980 for (s = SvPVX(sv); *s; s++) {
a0d0e21e 6981 if (*s == ':' && s[1] == ':') {
42d9b98d 6982 const STRLEN len = strlen(s+2)+1;
a0d0e21e 6983 *s = '/';
42d9b98d 6984 Move(s+2, s+1, len, char);
5c144d81 6985 SvCUR_set(sv, SvCUR(sv) - 1);
a0d0e21e 6986 }
8990e307 6987 }
396482e1 6988 sv_catpvs(sv, ".pm");
5c144d81 6989 SvFLAGS(sv) |= was_readonly;
8990e307
LW		 6990 }
6991 }
ec4ab249 6992
a72a1c8b
RGS		 6993 if (!(o->op_flags & OPf_SPECIAL)) { /* Wasn't written as CORE::require */
6994 /* handle override, if any */
fafc274c 6995 gv = gv_fetchpvs("require", GV_NOTQUAL, SVt_PVCV);
d6a985f2 6996 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
a4fc7abc 6997 GV * const * const gvp = (GV**)hv_fetchs(PL_globalstash, "require", FALSE);
a0714e2c 6998 gv = gvp ? *gvp : NULL;
d6a985f2 6999 }
a72a1c8b 7000 }
ec4ab249 7001
b9f751c0 7002 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
551405c4 7003 OP * const kid = cUNOPo->op_first;
f11453cb
NC		 7004 OP * newop;
7005
ec4ab249 7006 cUNOPo->op_first = 0;
f11453cb 7007#ifndef PERL_MAD
ec4ab249 7008 op_free(o);
eb8433b7 7009#endif
f11453cb
NC		 7010 newop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
7011 append_elem(OP_LIST, kid,
7012 scalar(newUNOP(OP_RV2CV, 0,
7013 newGVOP(OP_GV, 0,
7014 gv))))));
7015 op_getmad(o,newop,'O');
eb8433b7 7016 return newop;
ec4ab249
GA		 7017 }
7018
11343788 7019 return ck_fun(o);
8990e307
LW		 7020}
7021
78f9721b
SM		 7022OP *
7023Perl_ck_return(pTHX_ OP *o)
7024{
97aff369 7025 dVAR;
78f9721b 7026 if (CvLVALUE(PL_compcv)) {
6867be6d 7027 OP *kid;
78f9721b
SM		 7028 for (kid = cLISTOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
7029 mod(kid, OP_LEAVESUBLV);
7030 }
7031 return o;
7032}
7033
79072805 7034OP *
cea2e8a9 7035Perl_ck_select(pTHX_ OP *o)
79072805 7036{
27da23d5 7037 dVAR;
c07a80fd 7038 OP* kid;
11343788
MB		 7039 if (o->op_flags & OPf_KIDS) {
7040 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
2304df62 7041 if (kid && kid->op_sibling) {
11343788 7042 o->op_type = OP_SSELECT;
22c35a8c 7043 o->op_ppaddr = PL_ppaddr[OP_SSELECT];
11343788
MB		 7044 o = ck_fun(o);
7045 return fold_constants(o);
79072805
LW		 7046 }
7047 }
11343788
MB		 7048 o = ck_fun(o);
7049 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
c07a80fd 7050 if (kid && kid->op_type == OP_RV2GV)
7051 kid->op_private &= ~HINT_STRICT_REFS;
11343788 7052 return o;
79072805
LW		 7053}
7054
7055OP *
cea2e8a9 7056Perl_ck_shift(pTHX_ OP *o)
79072805 7057{
97aff369 7058 dVAR;
6867be6d 7059 const I32 type = o->op_type;
79072805 7060
11343788 7061 if (!(o->op_flags & OPf_KIDS)) {
6d4ff0d2 7062 OP *argop;
eb8433b7
NC		 7063 /* FIXME - this can be refactored to reduce code in #ifdefs */
7064#ifdef PERL_MAD
1d866c12 7065 OP * const oldo = o;
eb8433b7 7066#else
11343788 7067 op_free(o);
eb8433b7 7068#endif
6d4ff0d2 7069 argop = newUNOP(OP_RV2AV, 0,
8fde6460 7070 scalar(newGVOP(OP_GV, 0, CvUNIQUE(PL_compcv) ? PL_argvgv : PL_defgv)));
eb8433b7
NC		 7071#ifdef PERL_MAD
7072 o = newUNOP(type, 0, scalar(argop));
7073 op_getmad(oldo,o,'O');
7074 return o;
7075#else
6d4ff0d2 7076 return newUNOP(type, 0, scalar(argop));
eb8433b7 7077#endif
79072805 7078 }
11343788 7079 return scalar(modkids(ck_fun(o), type));
79072805
LW		 7080}
7081
7082OP *
cea2e8a9 7083Perl_ck_sort(pTHX_ OP *o)
79072805 7084{
97aff369 7085 dVAR;
8e3f9bdf 7086 OP *firstkid;
bbce6d69 7087
1496a290 7088 if (o->op_type == OP_SORT && (PL_hints & HINT_LOCALIZE_HH) != 0) {
a4fc7abc 7089 HV * const hinthv = GvHV(PL_hintgv);
7b9ef140 7090 if (hinthv) {
a4fc7abc 7091 SV ** const svp = hv_fetchs(hinthv, "sort", FALSE);
7b9ef140 7092 if (svp) {
a4fc7abc 7093 const I32 sorthints = (I32)SvIV(*svp);
7b9ef140
RH		 7094 if ((sorthints & HINT_SORT_QUICKSORT) != 0)
7095 o->op_private |= OPpSORT_QSORT;
7096 if ((sorthints & HINT_SORT_STABLE) != 0)
7097 o->op_private |= OPpSORT_STABLE;
7098 }
7099 }
7100 }
7101
9ea6e965 7102 if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
51a19bc0 7103 simplify_sort(o);
8e3f9bdf
GS		 7104 firstkid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
7105 if (o->op_flags & OPf_STACKED) { /* may have been cleared */
9c5ffd7c 7106 OP *k = NULL;
8e3f9bdf 7107 OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
79072805 7108
463ee0b2 7109 if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
79072805 7110 linklist(kid);
463ee0b2
LW		 7111 if (kid->op_type == OP_SCOPE) {
7112 k = kid->op_next;
7113 kid->op_next = 0;
79072805 7114 }
463ee0b2 7115 else if (kid->op_type == OP_LEAVE) {
11343788 7116 if (o->op_type == OP_SORT) {
93c66552 7117 op_null(kid); /* wipe out leave */
748a9306 7118 kid->op_next = kid;
463ee0b2 7119
748a9306
LW		 7120 for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
7121 if (k->op_next == kid)
7122 k->op_next = 0;
71a29c3c
GS		 7123 /* don't descend into loops */
7124 else if (k->op_type == OP_ENTERLOOP
7125 || k->op_type == OP_ENTERITER)
7126 {
7127 k = cLOOPx(k)->op_lastop;
7128 }
748a9306 7129 }
463ee0b2 7130 }
748a9306
LW		 7131 else
7132 kid->op_next = 0; /* just disconnect the leave */
a0d0e21e 7133 k = kLISTOP->op_first;
463ee0b2 7134 }
a2efc822 7135 CALL_PEEP(k);
a0d0e21e 7136
8e3f9bdf
GS		 7137 kid = firstkid;
7138 if (o->op_type == OP_SORT) {
7139 /* provide scalar context for comparison function/block */
7140 kid = scalar(kid);
a0d0e21e 7141 kid->op_next = kid;
8e3f9bdf 7142 }
a0d0e21e
LW		 7143 else
7144 kid->op_next = k;
11343788 7145 o->op_flags |= OPf_SPECIAL;
79072805 7146 }
c6e96bcb 7147 else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV)
93c66552 7148 op_null(firstkid);
8e3f9bdf
GS		 7149
7150 firstkid = firstkid->op_sibling;
79072805 7151 }
bbce6d69 7152
8e3f9bdf
GS		 7153 /* provide list context for arguments */
7154 if (o->op_type == OP_SORT)
7155 list(firstkid);
7156
11343788 7157 return o;
79072805 7158}
bda4119b
GS		 7159
7160STATIC void
cea2e8a9 7161S_simplify_sort(pTHX_ OP *o)
9c007264 7162{
97aff369 7163 dVAR;
9c007264
JH		 7164 register OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
7165 OP *k;
eb209983 7166 int descending;
350de78d 7167 GV *gv;
770526c1 7168 const char *gvname;
9c007264
JH		 7169 if (!(o->op_flags & OPf_STACKED))
7170 return;
fafc274c
NC		 7171 GvMULTI_on(gv_fetchpvs("a", GV_ADD|GV_NOTQUAL, SVt_PV));
7172 GvMULTI_on(gv_fetchpvs("b", GV_ADD|GV_NOTQUAL, SVt_PV));
82092f1d 7173 kid = kUNOP->op_first; /* get past null */
9c007264
JH		 7174 if (kid->op_type != OP_SCOPE)
7175 return;
7176 kid = kLISTOP->op_last; /* get past scope */
7177 switch(kid->op_type) {
7178 case OP_NCMP:
7179 case OP_I_NCMP:
7180 case OP_SCMP:
7181 break;
7182 default:
7183 return;
7184 }
7185 k = kid; /* remember this node*/
7186 if (kBINOP->op_first->op_type != OP_RV2SV)
7187 return;
7188 kid = kBINOP->op_first; /* get past cmp */
7189 if (kUNOP->op_first->op_type != OP_GV)
7190 return;
7191 kid = kUNOP->op_first; /* get past rv2sv */
638eceb6 7192 gv = kGVOP_gv;
350de78d 7193 if (GvSTASH(gv) != PL_curstash)
9c007264 7194 return;
770526c1
NC		 7195 gvname = GvNAME(gv);
7196 if (*gvname == 'a' && gvname[1] == '\0')
eb209983 7197 descending = 0;
770526c1 7198 else if (*gvname == 'b' && gvname[1] == '\0')
eb209983 7199 descending = 1;
9c007264
JH		 7200 else
7201 return;
eb209983 7202
9c007264
JH		 7203 kid = k; /* back to cmp */
7204 if (kBINOP->op_last->op_type != OP_RV2SV)
7205 return;
7206 kid = kBINOP->op_last; /* down to 2nd arg */
7207 if (kUNOP->op_first->op_type != OP_GV)
7208 return;
7209 kid = kUNOP->op_first; /* get past rv2sv */
638eceb6 7210 gv = kGVOP_gv;
770526c1
NC		 7211 if (GvSTASH(gv) != PL_curstash)
7212 return;
7213 gvname = GvNAME(gv);
7214 if ( descending
7215 ? !(*gvname == 'a' && gvname[1] == '\0')
7216 : !(*gvname == 'b' && gvname[1] == '\0'))
9c007264
JH		 7217 return;
7218 o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
eb209983
NC		 7219 if (descending)
7220 o->op_private |= OPpSORT_DESCEND;
9c007264
JH		 7221 if (k->op_type == OP_NCMP)
7222 o->op_private |= OPpSORT_NUMERIC;
7223 if (k->op_type == OP_I_NCMP)
7224 o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
e507f050
SM		 7225 kid = cLISTOPo->op_first->op_sibling;
7226 cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
eb8433b7
NC		 7227#ifdef PERL_MAD
7228 op_getmad(kid,o,'S'); /* then delete it */
7229#else
e507f050 7230 op_free(kid); /* then delete it */
eb8433b7 7231#endif
9c007264 7232}
79072805
LW		 7233
7234OP *
cea2e8a9 7235Perl_ck_split(pTHX_ OP *o)
79072805 7236{
27da23d5 7237 dVAR;
79072805 7238 register OP *kid;
aeea060c 7239
11343788
MB		 7240 if (o->op_flags & OPf_STACKED)
7241 return no_fh_allowed(o);
79072805 7242
11343788 7243 kid = cLISTOPo->op_first;
8990e307 7244 if (kid->op_type != OP_NULL)
cea2e8a9 7245 Perl_croak(aTHX_ "panic: ck_split");
8990e307 7246 kid = kid->op_sibling;
11343788
MB		 7247 op_free(cLISTOPo->op_first);
7248 cLISTOPo->op_first = kid;
85e6fe83 7249 if (!kid) {
396482e1 7250 cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvs(" "));
11343788 7251 cLISTOPo->op_last = kid; /* There was only one element previously */
85e6fe83 7252 }
79072805 7253
de4bf5b3 7254 if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
551405c4 7255 OP * const sibl = kid->op_sibling;
463ee0b2 7256 kid->op_sibling = 0;
131b3ad0 7257 kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, 0);
11343788
MB		 7258 if (cLISTOPo->op_first == cLISTOPo->op_last)
7259 cLISTOPo->op_last = kid;
7260 cLISTOPo->op_first = kid;
79072805
LW		 7261 kid->op_sibling = sibl;
7262 }
7263
7264 kid->op_type = OP_PUSHRE;
22c35a8c 7265 kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
79072805 7266 scalar(kid);
041457d9 7267 if (((PMOP *)kid)->op_pmflags & PMf_GLOBAL && ckWARN(WARN_REGEXP)) {
f34840d8
MJD		 7268 Perl_warner(aTHX_ packWARN(WARN_REGEXP),
7269 "Use of /g modifier is meaningless in split");
7270 }
79072805
LW		 7271
7272 if (!kid->op_sibling)
54b9620d 7273 append_elem(OP_SPLIT, o, newDEFSVOP());
79072805
LW		 7274
7275 kid = kid->op_sibling;
7276 scalar(kid);
7277
7278 if (!kid->op_sibling)
11343788 7279 append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
ce3e5c45 7280 assert(kid->op_sibling);
79072805
LW		 7281
7282 kid = kid->op_sibling;
7283 scalar(kid);
7284
7285 if (kid->op_sibling)
53e06cf0 7286 return too_many_arguments(o,OP_DESC(o));
79072805 7287
11343788 7288 return o;
79072805
LW		 7289}
7290
7291OP *
1c846c1f 7292Perl_ck_join(pTHX_ OP *o)
eb6e2d6f 7293{
551405c4 7294 const OP * const kid = cLISTOPo->op_first->op_sibling;
041457d9
DM		 7295 if (kid && kid->op_type == OP_MATCH) {
7296 if (ckWARN(WARN_SYNTAX)) {
6867be6d 7297 const REGEXP *re = PM_GETRE(kPMOP);
666ea192 7298 const char *pmstr = re ? re->precomp : "STRING";
9014280d 7299 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
eb6e2d6f
GS		 7300 "/%s/ should probably be written as \"%s\"",
7301 pmstr, pmstr);
7302 }
7303 }
7304 return ck_fun(o);
7305}
7306
7307OP *
cea2e8a9 7308Perl_ck_subr(pTHX_ OP *o)
79072805 7309{
97aff369 7310 dVAR;
11343788
MB		 7311 OP *prev = ((cUNOPo->op_first->op_sibling)
7312 ? cUNOPo : ((UNOP*)cUNOPo->op_first))->op_first;
7313 OP *o2 = prev->op_sibling;
4633a7c4 7314 OP *cvop;
a0751766 7315 const char *proto = NULL;
cbf82dd0 7316 const char *proto_end = NULL;
c445ea15
AL		 7317 CV *cv = NULL;
7318 GV *namegv = NULL;
4633a7c4
LW		 7319 int optional = 0;
7320 I32 arg = 0;
5b794e05 7321 I32 contextclass = 0;
d3fcec1f 7322 const char *e = NULL;
0723351e 7323 bool delete_op = 0;
4633a7c4 7324
d3011074 7325 o->op_private |= OPpENTERSUB_HASTARG;
11343788 7326 for (cvop = o2; cvop->op_sibling; cvop = cvop->op_sibling) ;
4633a7c4
LW		 7327 if (cvop->op_type == OP_RV2CV) {
7328 SVOP* tmpop;
11343788 7329 o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
93c66552 7330 op_null(cvop); /* disable rv2cv */
4633a7c4 7331 tmpop = (SVOP*)((UNOP*)cvop)->op_first;
76cd736e 7332 if (tmpop->op_type == OP_GV && !(o->op_private & OPpENTERSUB_AMPER)) {
638eceb6 7333 GV *gv = cGVOPx_gv(tmpop);
350de78d 7334 cv = GvCVu(gv);
76cd736e
GS		 7335 if (!cv)
7336 tmpop->op_private |= OPpEARLY_CV;
06492da6
SF		 7337 else {
7338 if (SvPOK(cv)) {
cbf82dd0 7339 STRLEN len;
06492da6 7340 namegv = CvANON(cv) ? gv : CvGV(cv);
cbf82dd0
NC		 7341 proto = SvPV((SV*)cv, len);
7342 proto_end = proto + len;
06492da6
SF		 7343 }
7344 if (CvASSERTION(cv)) {
ecd685f0
RGS		 7345 U32 asserthints = 0;
7346 HV *const hinthv = GvHV(PL_hintgv);
7347 if (hinthv) {
7348 SV **svp = hv_fetchs(hinthv, "assertions", FALSE);
7349 if (svp && *svp)
7350 asserthints = SvUV(*svp);
7351 }
7352 if (asserthints & HINT_ASSERTING) {
06492da6
SF		 7353 if (PERLDB_ASSERTION && PL_curstash != PL_debstash)
7354 o->op_private |= OPpENTERSUB_DB;
7355 }
8fa7688f 7356 else {
0723351e 7357 delete_op = 1;
ecd685f0 7358 if (!(asserthints & HINT_ASSERTIONSSEEN) && ckWARN(WARN_ASSERTIONS)) {
8fa7688f
SF		 7359 Perl_warner(aTHX_ packWARN(WARN_ASSERTIONS),
7360 "Impossible to activate assertion call");
7361 }
7362 }
06492da6 7363 }
46fc3d4c 7364 }
4633a7c4
LW		 7365 }
7366 }
f5d5a27c 7367 else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
7a52d87a
GS		 7368 if (o2->op_type == OP_CONST)
7369 o2->op_private &= ~OPpCONST_STRICT;
58a40671 7370 else if (o2->op_type == OP_LIST) {
5f66b61c
AL		 7371 OP * const sib = ((UNOP*)o2)->op_first->op_sibling;
7372 if (sib && sib->op_type == OP_CONST)
7373 sib->op_private &= ~OPpCONST_STRICT;
58a40671 7374 }
7a52d87a 7375 }
3280af22
NIS		 7376 o->op_private |= (PL_hints & HINT_STRICT_REFS);
7377 if (PERLDB_SUB && PL_curstash != PL_debstash)
11343788
MB		 7378 o->op_private |= OPpENTERSUB_DB;
7379 while (o2 != cvop) {
eb8433b7
NC		 7380 OP* o3;
7381 if (PL_madskills && o2->op_type == OP_NULL)
7382 o3 = ((UNOP*)o2)->op_first;
7383 else
7384 o3 = o2;
4633a7c4 7385 if (proto) {
cbf82dd0 7386 if (proto >= proto_end)
5dc0d613 7387 return too_many_arguments(o, gv_ename(namegv));
cbf82dd0
NC		 7388
7389 switch (*proto) {
4633a7c4
LW		 7390 case ';':
7391 optional = 1;
7392 proto++;
7393 continue;
b13fd70a 7394 case '_':
f00d1d61 7395 /* _ must be at the end */
cb40c25d 7396 if (proto[1] && proto[1] != ';')
f00d1d61 7397 goto oops;
4633a7c4
LW		 7398 case '$':
7399 proto++;
7400 arg++;
11343788 7401 scalar(o2);
4633a7c4
LW		 7402 break;
7403 case '%':
7404 case '@':
11343788 7405 list(o2);
4633a7c4
LW		 7406 arg++;
7407 break;
7408 case '&':
7409 proto++;
7410 arg++;
eb8433b7 7411 if (o3->op_type != OP_REFGEN && o3->op_type != OP_UNDEF)
75fc29ea 7412 bad_type(arg,
666ea192
JH		 7413 arg == 1 ? "block or sub {}" : "sub {}",
7414 gv_ename(namegv), o3);
4633a7c4
LW		 7415 break;
7416 case '*':
2ba6ecf4 7417 /* '*' allows any scalar type, including bareword */
4633a7c4
LW		 7418 proto++;
7419 arg++;
eb8433b7 7420 if (o3->op_type == OP_RV2GV)
2ba6ecf4 7421 goto wrapref; /* autoconvert GLOB -> GLOBref */
eb8433b7
NC		 7422 else if (o3->op_type == OP_CONST)
7423 o3->op_private &= ~OPpCONST_STRICT;
7424 else if (o3->op_type == OP_ENTERSUB) {
9675f7ac 7425 /* accidental subroutine, revert to bareword */
eb8433b7 7426 OP *gvop = ((UNOP*)o3)->op_first;
9675f7ac
GS		 7427 if (gvop && gvop->op_type == OP_NULL) {
7428 gvop = ((UNOP*)gvop)->op_first;
7429 if (gvop) {
7430 for (; gvop->op_sibling; gvop = gvop->op_sibling)
7431 ;
7432 if (gvop &&
7433 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
7434 (gvop = ((UNOP*)gvop)->op_first) &&
7435 gvop->op_type == OP_GV)
7436 {
551405c4
AL		 7437 GV * const gv = cGVOPx_gv(gvop);
7438 OP * const sibling = o2->op_sibling;
396482e1 7439 SV * const n = newSVpvs("");
eb8433b7 7440#ifdef PERL_MAD
1d866c12 7441 OP * const oldo2 = o2;
eb8433b7 7442#else
9675f7ac 7443 op_free(o2);
eb8433b7 7444#endif
2a797ae2 7445 gv_fullname4(n, gv, "", FALSE);
2692f720 7446 o2 = newSVOP(OP_CONST, 0, n);
eb8433b7 7447 op_getmad(oldo2,o2,'O');
9675f7ac
GS		 7448 prev->op_sibling = o2;
7449 o2->op_sibling = sibling;
7450 }
7451 }
7452 }
7453 }
2ba6ecf4
GS		 7454 scalar(o2);
7455 break;
5b794e05
JH		 7456 case '[': case ']':
7457 goto oops;
7458 break;
4633a7c4
LW		 7459 case '\\':
7460 proto++;
7461 arg++;
5b794e05 7462 again:
4633a7c4 7463 switch (*proto++) {
5b794e05
JH		 7464 case '[':
7465 if (contextclass++ == 0) {
841d93c8 7466 e = strchr(proto, ']');
5b794e05
JH		 7467 if (!e || e == proto)
7468 goto oops;
7469 }
7470 else
7471 goto oops;
7472 goto again;
7473 break;
7474 case ']':
466bafcd 7475 if (contextclass) {
a0751766
NC		 7476 const char *p = proto;
7477 const char *const end = proto;
466bafcd 7478 contextclass = 0;
466bafcd 7479 while (*--p != '[');
a0751766
NC		 7480 bad_type(arg, Perl_form(aTHX_ "one of %.*s",
7481 (int)(end - p), p),
7482 gv_ename(namegv), o3);
466bafcd 7483 } else
5b794e05
JH		 7484 goto oops;
7485 break;
4633a7c4 7486 case '*':
eb8433b7 7487 if (o3->op_type == OP_RV2GV)
5b794e05
JH		 7488 goto wrapref;
7489 if (!contextclass)
eb8433b7 7490 bad_type(arg, "symbol", gv_ename(namegv), o3);
5b794e05 7491 break;
4633a7c4 7492 case '&':
eb8433b7 7493 if (o3->op_type == OP_ENTERSUB)
5b794e05
JH		 7494 goto wrapref;
7495 if (!contextclass)
eb8433b7
NC		 7496 bad_type(arg, "subroutine entry", gv_ename(namegv),
7497 o3);
5b794e05 7498 break;
4633a7c4 7499 case '$':
eb8433b7
NC		 7500 if (o3->op_type == OP_RV2SV ||
7501 o3->op_type == OP_PADSV ||
7502 o3->op_type == OP_HELEM ||
7503 o3->op_type == OP_AELEM ||
7504 o3->op_type == OP_THREADSV)
5b794e05
JH		 7505 goto wrapref;
7506 if (!contextclass)
eb8433b7 7507 bad_type(arg, "scalar", gv_ename(namegv), o3);
5b794e05 7508 break;
4633a7c4 7509 case '@':
eb8433b7
NC		 7510 if (o3->op_type == OP_RV2AV ||
7511 o3->op_type == OP_PADAV)
5b794e05
JH		 7512 goto wrapref;
7513 if (!contextclass)
eb8433b7 7514 bad_type(arg, "array", gv_ename(namegv), o3);
5b794e05 7515 break;
4633a7c4 7516 case '%':
eb8433b7
NC		 7517 if (o3->op_type == OP_RV2HV ||
7518 o3->op_type == OP_PADHV)
5b794e05
JH		 7519 goto wrapref;
7520 if (!contextclass)
eb8433b7 7521 bad_type(arg, "hash", gv_ename(namegv), o3);
5b794e05
JH		 7522 break;
7523 wrapref:
4633a7c4 7524 {
551405c4
AL		 7525 OP* const kid = o2;
7526 OP* const sib = kid->op_sibling;
4633a7c4 7527 kid->op_sibling = 0;
6fa846a0
GS		 7528 o2 = newUNOP(OP_REFGEN, 0, kid);
7529 o2->op_sibling = sib;
e858de61 7530 prev->op_sibling = o2;
4633a7c4 7531 }
841d93c8 7532 if (contextclass && e) {
5b794e05
JH		 7533 proto = e + 1;
7534 contextclass = 0;
7535 }
4633a7c4
LW		 7536 break;
7537 default: goto oops;
7538 }
5b794e05
JH		 7539 if (contextclass)
7540 goto again;
4633a7c4 7541 break;
b1cb66bf 7542 case ' ':
7543 proto++;
7544 continue;
4633a7c4
LW		 7545 default:
7546 oops:
35c1215d 7547 Perl_croak(aTHX_ "Malformed prototype for %s: %"SVf,
95b63a38 7548 gv_ename(namegv), (void*)cv);
4633a7c4
LW		 7549 }
7550 }
7551 else
11343788
MB		 7552 list(o2);
7553 mod(o2, OP_ENTERSUB);
7554 prev = o2;
7555 o2 = o2->op_sibling;
551405c4 7556 } /* while */
236b555a
RGS		 7557 if (o2 == cvop && proto && *proto == '_') {
7558 /* generate an access to $_ */
7559 o2 = newDEFSVOP();
7560 o2->op_sibling = prev->op_sibling;
7561 prev->op_sibling = o2; /* instead of cvop */
7562 }
cbf82dd0 7563 if (proto && !optional && proto_end > proto &&
236b555a 7564 (*proto != '@' && *proto != '%' && *proto != ';' && *proto != '_'))
5dc0d613 7565 return too_few_arguments(o, gv_ename(namegv));
0723351e 7566 if(delete_op) {
eb8433b7 7567#ifdef PERL_MAD
1d866c12 7568 OP * const oldo = o;
eb8433b7 7569#else
06492da6 7570 op_free(o);
eb8433b7 7571#endif
06492da6 7572 o=newSVOP(OP_CONST, 0, newSViv(0));
eb8433b7 7573 op_getmad(oldo,o,'O');
06492da6 7574 }
11343788 7575 return o;
79072805
LW		 7576}
7577
7578OP *
cea2e8a9 7579Perl_ck_svconst(pTHX_ OP *o)
8990e307 7580{
96a5add6 7581 PERL_UNUSED_CONTEXT;
11343788
MB		 7582 SvREADONLY_on(cSVOPo->op_sv);
7583 return o;
8990e307
LW		 7584}
7585
7586OP *
d4ac975e
GA		 7587Perl_ck_chdir(pTHX_ OP *o)
7588{
7589 if (o->op_flags & OPf_KIDS) {
1496a290 7590 SVOP * const kid = (SVOP*)cUNOPo->op_first;
d4ac975e
GA		 7591
7592 if (kid && kid->op_type == OP_CONST &&
7593 (kid->op_private & OPpCONST_BARE))
7594 {
7595 o->op_flags |= OPf_SPECIAL;
7596 kid->op_private &= ~OPpCONST_STRICT;
7597 }
7598 }
7599 return ck_fun(o);
7600}
7601
7602OP *
cea2e8a9 7603Perl_ck_trunc(pTHX_ OP *o)
79072805 7604{
11343788
MB		 7605 if (o->op_flags & OPf_KIDS) {
7606 SVOP *kid = (SVOP*)cUNOPo->op_first;
79072805 7607
a0d0e21e
LW		 7608 if (kid->op_type == OP_NULL)
7609 kid = (SVOP*)kid->op_sibling;
bb53490d
GS		 7610 if (kid && kid->op_type == OP_CONST &&
7611 (kid->op_private & OPpCONST_BARE))
7612 {
11343788 7613 o->op_flags |= OPf_SPECIAL;
bb53490d
GS		 7614 kid->op_private &= ~OPpCONST_STRICT;
7615 }
79072805 7616 }
11343788 7617 return ck_fun(o);
79072805
LW		 7618}
7619
35fba0d9 7620OP *
bab9c0ac
RGS		 7621Perl_ck_unpack(pTHX_ OP *o)
7622{
7623 OP *kid = cLISTOPo->op_first;
7624 if (kid->op_sibling) {
7625 kid = kid->op_sibling;
7626 if (!kid->op_sibling)
7627 kid->op_sibling = newDEFSVOP();
7628 }
7629 return ck_fun(o);
7630}
7631
7632OP *
35fba0d9
RG		 7633Perl_ck_substr(pTHX_ OP *o)
7634{
7635 o = ck_fun(o);
1d866c12 7636 if ((o->op_flags & OPf_KIDS) && (o->op_private == 4)) {
35fba0d9
RG		 7637 OP *kid = cLISTOPo->op_first;
7638
7639 if (kid->op_type == OP_NULL)
7640 kid = kid->op_sibling;
7641 if (kid)
7642 kid->op_flags |= OPf_MOD;
7643
7644 }
7645 return o;
7646}
7647
61b743bb
DM		 7648/* A peephole optimizer. We visit the ops in the order they're to execute.
7649 * See the comments at the top of this file for more details about when
7650 * peep() is called */
463ee0b2 7651
79072805 7652void
864dbfa3 7653Perl_peep(pTHX_ register OP *o)
79072805 7654{
27da23d5 7655 dVAR;
c445ea15 7656 register OP* oldop = NULL;
2d8e6c8d 7657
2814eb74 7658 if (!o || o->op_opt)
79072805 7659 return;
a0d0e21e 7660 ENTER;
462e5cf6 7661 SAVEOP();
7766f137 7662 SAVEVPTR(PL_curcop);
a0d0e21e 7663 for (; o; o = o->op_next) {
2814eb74 7664 if (o->op_opt)
a0d0e21e 7665 break;
533c011a 7666 PL_op = o;
a0d0e21e 7667 switch (o->op_type) {
acb36ea4 7668 case OP_SETSTATE:
a0d0e21e
LW		 7669 case OP_NEXTSTATE:
7670 case OP_DBSTATE:
3280af22 7671 PL_curcop = ((COP*)o); /* for warnings */
2814eb74 7672 o->op_opt = 1;
a0d0e21e
LW		 7673 break;
7674
a0d0e21e 7675 case OP_CONST:
7a52d87a
GS		 7676 if (cSVOPo->op_private & OPpCONST_STRICT)
7677 no_bareword_allowed(o);
7766f137 7678#ifdef USE_ITHREADS
3848b962 7679 case OP_METHOD_NAMED:
7766f137
GS		 7680 /* Relocate sv to the pad for thread safety.
7681 * Despite being a "constant", the SV is written to,
7682 * for reference counts, sv_upgrade() etc. */
7683 if (cSVOP->op_sv) {
6867be6d 7684 const PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
330e22d5 7685 if (o->op_type == OP_CONST && SvPADTMP(cSVOPo->op_sv)) {
6a7129a1 7686 /* If op_sv is already a PADTMP then it is being used by
9a049f1c 7687 * some pad, so make a copy. */
dd2155a4
DM		 7688 sv_setsv(PAD_SVl(ix),cSVOPo->op_sv);
7689 SvREADONLY_on(PAD_SVl(ix));
6a7129a1
GS		 7690 SvREFCNT_dec(cSVOPo->op_sv);
7691 }
052ca17e
NC		 7692 else if (o->op_type == OP_CONST
7693 && cSVOPo->op_sv == &PL_sv_undef) {
7694 /* PL_sv_undef is hack - it's unsafe to store it in the
7695 AV that is the pad, because av_fetch treats values of
7696 PL_sv_undef as a "free" AV entry and will merrily
7697 replace them with a new SV, causing pad_alloc to think
7698 that this pad slot is free. (When, clearly, it is not)
7699 */
7700 SvOK_off(PAD_SVl(ix));
7701 SvPADTMP_on(PAD_SVl(ix));
7702 SvREADONLY_on(PAD_SVl(ix));
7703 }
6a7129a1 7704 else {
dd2155a4 7705 SvREFCNT_dec(PAD_SVl(ix));
6a7129a1 7706 SvPADTMP_on(cSVOPo->op_sv);
dd2155a4 7707 PAD_SETSV(ix, cSVOPo->op_sv);
9a049f1c 7708 /* XXX I don't know how this isn't readonly already. */
dd2155a4 7709 SvREADONLY_on(PAD_SVl(ix));
6a7129a1 7710 }
a0714e2c 7711 cSVOPo->op_sv = NULL;
7766f137
GS		 7712 o->op_targ = ix;
7713 }
7714#endif
2814eb74 7715 o->op_opt = 1;
07447971
GS		 7716 break;
7717
df91b2c5
AE		 7718 case OP_CONCAT:
7719 if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
7720 if (o->op_next->op_private & OPpTARGET_MY) {
7721 if (o->op_flags & OPf_STACKED) /* chained concats */
7722 goto ignore_optimization;
7723 else {
7724 /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
7725 o->op_targ = o->op_next->op_targ;
7726 o->op_next->op_targ = 0;
7727 o->op_private |= OPpTARGET_MY;
7728 }
7729 }
7730 op_null(o->op_next);
7731 }
7732 ignore_optimization:
2814eb74 7733 o->op_opt = 1;
df91b2c5 7734 break;
8990e307 7735 case OP_STUB:
54310121 7736 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
2814eb74 7737 o->op_opt = 1;
54310121 7738 break; /* Scalar stub must produce undef. List stub is noop */
8990e307 7739 }
748a9306 7740 goto nothin;
79072805 7741 case OP_NULL:
acb36ea4
GS		 7742 if (o->op_targ == OP_NEXTSTATE
7743 || o->op_targ == OP_DBSTATE
7744 || o->op_targ == OP_SETSTATE)
7745 {
3280af22 7746 PL_curcop = ((COP*)o);
acb36ea4 7747 }
dad75012
AMS		 7748 /* XXX: We avoid setting op_seq here to prevent later calls
7749 to peep() from mistakenly concluding that optimisation
7750 has already occurred. This doesn't fix the real problem,
7751 though (See 20010220.007). AMS 20010719 */
2814eb74 7752 /* op_seq functionality is now replaced by op_opt */
dad75012
AMS		 7753 if (oldop && o->op_next) {
7754 oldop->op_next = o->op_next;
7755 continue;
7756 }
7757 break;
79072805 7758 case OP_SCALAR:
93a17b20 7759 case OP_LINESEQ:
463ee0b2 7760 case OP_SCOPE:
748a9306 7761 nothin:
a0d0e21e
LW		 7762 if (oldop && o->op_next) {
7763 oldop->op_next = o->op_next;
79072805
LW		 7764 continue;
7765 }
2814eb74 7766 o->op_opt = 1;
79072805
LW		 7767 break;
7768
6a077020 7769 case OP_PADAV:
79072805 7770 case OP_GV:
6a077020 7771 if (o->op_type == OP_PADAV || o->op_next->op_type == OP_RV2AV) {
0bd48802 7772 OP* const pop = (o->op_type == OP_PADAV) ?
6a077020 7773 o->op_next : o->op_next->op_next;
a0d0e21e 7774 IV i;
f9dc862f 7775 if (pop && pop->op_type == OP_CONST &&
af5acbb4 7776 ((PL_op = pop->op_next)) &&
8990e307 7777 pop->op_next->op_type == OP_AELEM &&
a0d0e21e 7778 !(pop->op_next->op_private &
78f9721b 7779 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
fc15ae8f 7780 (i = SvIV(((SVOP*)pop)->op_sv) - CopARYBASE_get(PL_curcop))
a0d0e21e 7781 <= 255 &&
8990e307
LW		 7782 i >= 0)
7783 {
350de78d 7784 GV *gv;
af5acbb4
DM		 7785 if (cSVOPx(pop)->op_private & OPpCONST_STRICT)
7786 no_bareword_allowed(pop);
6a077020
DM		 7787 if (o->op_type == OP_GV)
7788 op_null(o->op_next);
93c66552
DM		 7789 op_null(pop->op_next);
7790 op_null(pop);
a0d0e21e
LW		 7791 o->op_flags |= pop->op_next->op_flags & OPf_MOD;
7792 o->op_next = pop->op_next->op_next;
22c35a8c 7793 o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
a0d0e21e 7794 o->op_private = (U8)i;
6a077020
DM		 7795 if (o->op_type == OP_GV) {
7796 gv = cGVOPo_gv;
7797 GvAVn(gv);
7798 }
7799 else
7800 o->op_flags |= OPf_SPECIAL;
7801 o->op_type = OP_AELEMFAST;
7802 }
7803 o->op_opt = 1;
7804 break;
7805 }
7806
7807 if (o->op_next->op_type == OP_RV2SV) {
7808 if (!(o->op_next->op_private & OPpDEREF)) {
7809 op_null(o->op_next);
7810 o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
7811 | OPpOUR_INTRO);
7812 o->op_next = o->op_next->op_next;
7813 o->op_type = OP_GVSV;
7814 o->op_ppaddr = PL_ppaddr[OP_GVSV];
8990e307 7815 }
79072805 7816 }
e476b1b5 7817 else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
551405c4 7818 GV * const gv = cGVOPo_gv;
b15aece3 7819 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX_const(GvCV(gv))) {
76cd736e 7820 /* XXX could check prototype here instead of just carping */
551405c4 7821 SV * const sv = sv_newmortal();
bd61b366 7822 gv_efullname3(sv, gv, NULL);
9014280d 7823 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
35c1215d 7824 "%"SVf"() called too early to check prototype",
95b63a38 7825 (void*)sv);
76cd736e
GS		 7826 }
7827 }
89de2904
AMS		 7828 else if (o->op_next->op_type == OP_READLINE
7829 && o->op_next->op_next->op_type == OP_CONCAT
7830 && (o->op_next->op_next->op_flags & OPf_STACKED))
7831 {
d2c45030
AMS		 7832 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
7833 o->op_type = OP_RCATLINE;
7834 o->op_flags |= OPf_STACKED;
7835 o->op_ppaddr = PL_ppaddr[OP_RCATLINE];
89de2904 7836 op_null(o->op_next->op_next);
d2c45030 7837 op_null(o->op_next);
89de2904 7838 }
76cd736e 7839
2814eb74 7840 o->op_opt = 1;
79072805
LW		 7841 break;
7842
a0d0e21e 7843 case OP_MAPWHILE:
79072805
LW		 7844 case OP_GREPWHILE:
7845 case OP_AND:
7846 case OP_OR:
c963b151 7847 case OP_DOR:
2c2d71f5
JH		 7848 case OP_ANDASSIGN:
7849 case OP_ORASSIGN:
c963b151 7850 case OP_DORASSIGN:
1a67a97c
SM		 7851 case OP_COND_EXPR:
7852 case OP_RANGE:
2814eb74 7853 o->op_opt = 1;
fd4d1407
IZ		 7854 while (cLOGOP->op_other->op_type == OP_NULL)
7855 cLOGOP->op_other = cLOGOP->op_other->op_next;
a2efc822 7856 peep(cLOGOP->op_other); /* Recursive calls are not replaced by fptr calls */
79072805
LW		 7857 break;
7858
79072805 7859 case OP_ENTERLOOP:
9c2ca71a 7860 case OP_ENTERITER:
2814eb74 7861 o->op_opt = 1;
58cccf98
SM		 7862 while (cLOOP->op_redoop->op_type == OP_NULL)
7863 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
79072805 7864 peep(cLOOP->op_redoop);
58cccf98
SM		 7865 while (cLOOP->op_nextop->op_type == OP_NULL)
7866 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
79072805 7867 peep(cLOOP->op_nextop);
58cccf98
SM		 7868 while (cLOOP->op_lastop->op_type == OP_NULL)
7869 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
79072805
LW		 7870 peep(cLOOP->op_lastop);
7871 break;
7872
8782bef2 7873 case OP_QR:
79072805
LW		 7874 case OP_MATCH:
7875 case OP_SUBST:
2814eb74 7876 o->op_opt = 1;
9041c2e3 7877 while (cPMOP->op_pmreplstart &&
58cccf98
SM		 7878 cPMOP->op_pmreplstart->op_type == OP_NULL)
7879 cPMOP->op_pmreplstart = cPMOP->op_pmreplstart->op_next;
a0d0e21e 7880 peep(cPMOP->op_pmreplstart);
79072805
LW		 7881 break;
7882
a0d0e21e 7883 case OP_EXEC:
2814eb74 7884 o->op_opt = 1;
041457d9
DM		 7885 if (o->op_next && o->op_next->op_type == OP_NEXTSTATE
7886 && ckWARN(WARN_SYNTAX))
7887 {
1496a290
AL		 7888 if (o->op_next->op_sibling) {
7889 const OPCODE type = o->op_next->op_sibling->op_type;
7890 if (type != OP_EXIT && type != OP_WARN && type != OP_DIE) {
7891 const line_t oldline = CopLINE(PL_curcop);
7892 CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next));
7893 Perl_warner(aTHX_ packWARN(WARN_EXEC),
7894 "Statement unlikely to be reached");
7895 Perl_warner(aTHX_ packWARN(WARN_EXEC),
7896 "\t(Maybe you meant system() when you said exec()?)\n");
7897 CopLINE_set(PL_curcop, oldline);
7898 }
a0d0e21e
LW		 7899 }
7900 }
7901 break;
b2ffa427 7902
c750a3ec 7903 case OP_HELEM: {
e75d1f10 7904 UNOP *rop;
6d822dc4 7905 SV *lexname;
e75d1f10 7906 GV **fields;
6d822dc4 7907 SV **svp, *sv;
d5263905 7908 const char *key = NULL;
c750a3ec 7909 STRLEN keylen;
b2ffa427 7910
2814eb74 7911 o->op_opt = 1;
1c846c1f
NIS		 7912
7913 if (((BINOP*)o)->op_last->op_type != OP_CONST)
c750a3ec 7914 break;
1c846c1f
NIS		 7915
7916 /* Make the CONST have a shared SV */
7917 svp = cSVOPx_svp(((BINOP*)o)->op_last);
3049cdab 7918 if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv)) && !IS_PADCONST(sv)) {
d5263905 7919 key = SvPV_const(sv, keylen);
25716404 7920 lexname = newSVpvn_share(key,
bb7a0f54 7921 SvUTF8(sv) ? -(I32)keylen : (I32)keylen,
25716404 7922 0);
1c846c1f
NIS		 7923 SvREFCNT_dec(sv);
7924 *svp = lexname;
7925 }
e75d1f10
RD		 7926
7927 if ((o->op_private & (OPpLVAL_INTRO)))
7928 break;
7929
7930 rop = (UNOP*)((BINOP*)o)->op_first;
7931 if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
7932 break;
7933 lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
00b1698f 7934 if (!SvPAD_TYPED(lexname))
e75d1f10 7935 break;
a4fc7abc 7936 fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE);
e75d1f10
RD		 7937 if (!fields || !GvHV(*fields))
7938 break;
93524f2b 7939 key = SvPV_const(*svp, keylen);
e75d1f10 7940 if (!hv_fetch(GvHV(*fields), key,
bb7a0f54 7941 SvUTF8(*svp) ? -(I32)keylen : (I32)keylen, FALSE))
e75d1f10
RD		 7942 {
7943 Perl_croak(aTHX_ "No such class field \"%s\" "
7944 "in variable %s of type %s",
93524f2b 7945 key, SvPV_nolen_const(lexname), HvNAME_get(SvSTASH(lexname)));
e75d1f10
RD		 7946 }
7947
6d822dc4
MS		 7948 break;
7949 }
c750a3ec 7950
e75d1f10
RD		 7951 case OP_HSLICE: {
7952 UNOP *rop;
7953 SV *lexname;
7954 GV **fields;
7955 SV **svp;
93524f2b 7956 const char *key;
e75d1f10
RD		 7957 STRLEN keylen;
7958 SVOP *first_key_op, *key_op;
7959
7960 if ((o->op_private & (OPpLVAL_INTRO))
7961 /* I bet there's always a pushmark... */
7962 || ((LISTOP*)o)->op_first->op_sibling->op_type != OP_LIST)
7963 /* hmmm, no optimization if list contains only one key. */
7964 break;
7965 rop = (UNOP*)((LISTOP*)o)->op_last;
7966 if (rop->op_type != OP_RV2HV)
7967 break;
7968 if (rop->op_first->op_type == OP_PADSV)
7969 /* @$hash{qw(keys here)} */
7970 rop = (UNOP*)rop->op_first;
7971 else {
7972 /* @{$hash}{qw(keys here)} */
7973 if (rop->op_first->op_type == OP_SCOPE
7974 && cLISTOPx(rop->op_first)->op_last->op_type == OP_PADSV)
7975 {
7976 rop = (UNOP*)cLISTOPx(rop->op_first)->op_last;
7977 }
7978 else
7979 break;
7980 }
7981
7982 lexname = *av_fetch(PL_comppad_name, rop->op_targ, TRUE);
00b1698f 7983 if (!SvPAD_TYPED(lexname))
e75d1f10 7984 break;
a4fc7abc 7985 fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE);
e75d1f10
RD		 7986 if (!fields || !GvHV(*fields))
7987 break;
7988 /* Again guessing that the pushmark can be jumped over.... */
7989 first_key_op = (SVOP*)((LISTOP*)((LISTOP*)o)->op_first->op_sibling)
7990 ->op_first->op_sibling;
7991 for (key_op = first_key_op; key_op;
7992 key_op = (SVOP*)key_op->op_sibling) {
7993 if (key_op->op_type != OP_CONST)
7994 continue;
7995 svp = cSVOPx_svp(key_op);
93524f2b 7996 key = SvPV_const(*svp, keylen);
e75d1f10 7997 if (!hv_fetch(GvHV(*fields), key,
bb7a0f54 7998 SvUTF8(*svp) ? -(I32)keylen : (I32)keylen, FALSE))
e75d1f10
RD		 7999 {
8000 Perl_croak(aTHX_ "No such class field \"%s\" "
8001 "in variable %s of type %s",
bfcb3514 8002 key, SvPV_nolen(lexname), HvNAME_get(SvSTASH(lexname)));
e75d1f10
RD		 8003 }
8004 }
8005 break;
8006 }
8007
fe1bc4cf 8008 case OP_SORT: {
fe1bc4cf 8009 /* will point to RV2AV or PADAV op on LHS/RHS of assign */
551405c4 8010 OP *oleft;
fe1bc4cf
DM		 8011 OP *o2;
8012
fe1bc4cf 8013 /* check that RHS of sort is a single plain array */
551405c4 8014 OP *oright = cUNOPo->op_first;
fe1bc4cf
DM		 8015 if (!oright || oright->op_type != OP_PUSHMARK)
8016 break;
471178c0
NC		 8017
8018 /* reverse sort ... can be optimised. */
8019 if (!cUNOPo->op_sibling) {
8020 /* Nothing follows us on the list. */
551405c4 8021 OP * const reverse = o->op_next;
471178c0
NC		 8022
8023 if (reverse->op_type == OP_REVERSE &&
8024 (reverse->op_flags & OPf_WANT) == OPf_WANT_LIST) {
551405c4 8025 OP * const pushmark = cUNOPx(reverse)->op_first;
471178c0
NC		 8026 if (pushmark && (pushmark->op_type == OP_PUSHMARK)
8027 && (cUNOPx(pushmark)->op_sibling == o)) {
8028 /* reverse -> pushmark -> sort */
8029 o->op_private |= OPpSORT_REVERSE;
8030 op_null(reverse);
8031 pushmark->op_next = oright->op_next;
8032 op_null(oright);
8033 }
8034 }
8035 }
8036
8037 /* make @a = sort @a act in-place */
8038
8039 o->op_opt = 1;
8040
fe1bc4cf
DM		 8041 oright = cUNOPx(oright)->op_sibling;
8042 if (!oright)
8043 break;
8044 if (oright->op_type == OP_NULL) { /* skip sort block/sub */
8045 oright = cUNOPx(oright)->op_sibling;
8046 }
8047
8048 if (!oright ||
8049 (oright->op_type != OP_RV2AV && oright->op_type != OP_PADAV)
8050 || oright->op_next != o
8051 || (oright->op_private & OPpLVAL_INTRO)
8052 )
8053 break;
8054
8055 /* o2 follows the chain of op_nexts through the LHS of the
8056 * assign (if any) to the aassign op itself */
8057 o2 = o->op_next;
8058 if (!o2 || o2->op_type != OP_NULL)
8059 break;
8060 o2 = o2->op_next;
8061 if (!o2 || o2->op_type != OP_PUSHMARK)
8062 break;
8063 o2 = o2->op_next;
8064 if (o2 && o2->op_type == OP_GV)
8065 o2 = o2->op_next;
8066 if (!o2
8067 || (o2->op_type != OP_PADAV && o2->op_type != OP_RV2AV)
8068 || (o2->op_private & OPpLVAL_INTRO)
8069 )
8070 break;
8071 oleft = o2;
8072 o2 = o2->op_next;
8073 if (!o2 || o2->op_type != OP_NULL)
8074 break;
8075 o2 = o2->op_next;
8076 if (!o2 || o2->op_type != OP_AASSIGN
8077 || (o2->op_flags & OPf_WANT) != OPf_WANT_VOID)
8078 break;
8079
db7511db
DM		 8080 /* check that the sort is the first arg on RHS of assign */
8081
8082 o2 = cUNOPx(o2)->op_first;
8083 if (!o2 || o2->op_type != OP_NULL)
8084 break;
8085 o2 = cUNOPx(o2)->op_first;
8086 if (!o2 || o2->op_type != OP_PUSHMARK)
8087 break;
8088 if (o2->op_sibling != o)
8089 break;
8090
fe1bc4cf
DM		 8091 /* check the array is the same on both sides */
8092 if (oleft->op_type == OP_RV2AV) {
8093 if (oright->op_type != OP_RV2AV
8094 || !cUNOPx(oright)->op_first
8095 || cUNOPx(oright)->op_first->op_type != OP_GV
8096 || cGVOPx_gv(cUNOPx(oleft)->op_first) !=
8097 cGVOPx_gv(cUNOPx(oright)->op_first)
8098 )
8099 break;
8100 }
8101 else if (oright->op_type != OP_PADAV
8102 || oright->op_targ != oleft->op_targ
8103 )
8104 break;
8105
8106 /* transfer MODishness etc from LHS arg to RHS arg */
8107 oright->op_flags = oleft->op_flags;
8108 o->op_private |= OPpSORT_INPLACE;
8109
8110 /* excise push->gv->rv2av->null->aassign */
8111 o2 = o->op_next->op_next;
8112 op_null(o2); /* PUSHMARK */
8113 o2 = o2->op_next;
8114 if (o2->op_type == OP_GV) {
8115 op_null(o2); /* GV */
8116 o2 = o2->op_next;
8117 }
8118 op_null(o2); /* RV2AV or PADAV */
8119 o2 = o2->op_next->op_next;
8120 op_null(o2); /* AASSIGN */
8121
8122 o->op_next = o2->op_next;
8123
8124 break;
8125 }
ef3e5ea9
NC		 8126
8127 case OP_REVERSE: {
e682d7b7 8128 OP *ourmark, *theirmark, *ourlast, *iter, *expushmark, *rv2av;
ce335f37 8129 OP *gvop = NULL;
ef3e5ea9
NC		 8130 LISTOP *enter, *exlist;
8131 o->op_opt = 1;
8132
8133 enter = (LISTOP *) o->op_next;
8134 if (!enter)
8135 break;
8136 if (enter->op_type == OP_NULL) {
8137 enter = (LISTOP *) enter->op_next;
8138 if (!enter)
8139 break;
8140 }
d46f46af
NC		 8141 /* for $a (...) will have OP_GV then OP_RV2GV here.
8142 for (...) just has an OP_GV. */
ce335f37
NC		 8143 if (enter->op_type == OP_GV) {
8144 gvop = (OP *) enter;
8145 enter = (LISTOP *) enter->op_next;
8146 if (!enter)
8147 break;
d46f46af
NC		 8148 if (enter->op_type == OP_RV2GV) {
8149 enter = (LISTOP *) enter->op_next;
8150 if (!enter)
ce335f37 8151 break;
d46f46af 8152 }
ce335f37
NC		 8153 }
8154
ef3e5ea9
NC		 8155 if (enter->op_type != OP_ENTERITER)
8156 break;
8157
8158 iter = enter->op_next;
8159 if (!iter || iter->op_type != OP_ITER)
8160 break;
8161
ce335f37
NC		 8162 expushmark = enter->op_first;
8163 if (!expushmark || expushmark->op_type != OP_NULL
8164 || expushmark->op_targ != OP_PUSHMARK)
8165 break;
8166
8167 exlist = (LISTOP *) expushmark->op_sibling;
ef3e5ea9
NC		 8168 if (!exlist || exlist->op_type != OP_NULL
8169 || exlist->op_targ != OP_LIST)
8170 break;
8171
8172 if (exlist->op_last != o) {
8173 /* Mmm. Was expecting to point back to this op. */
8174 break;
8175 }
8176 theirmark = exlist->op_first;
8177 if (!theirmark || theirmark->op_type != OP_PUSHMARK)
8178 break;
8179
c491ecac 8180 if (theirmark->op_sibling != o) {
ef3e5ea9
NC		 8181 /* There's something between the mark and the reverse, eg
8182 for (1, reverse (...))
8183 so no go. */
8184 break;
8185 }
8186
c491ecac
NC		 8187 ourmark = ((LISTOP *)o)->op_first;
8188 if (!ourmark || ourmark->op_type != OP_PUSHMARK)
8189 break;
8190
ef3e5ea9
NC		 8191 ourlast = ((LISTOP *)o)->op_last;
8192 if (!ourlast || ourlast->op_next != o)
8193 break;
8194
e682d7b7
NC		 8195 rv2av = ourmark->op_sibling;
8196 if (rv2av && rv2av->op_type == OP_RV2AV && rv2av->op_sibling == 0
8197 && rv2av->op_flags == (OPf_WANT_LIST | OPf_KIDS)
8198 && enter->op_flags == (OPf_WANT_LIST | OPf_KIDS)) {
8199 /* We're just reversing a single array. */
8200 rv2av->op_flags = OPf_WANT_SCALAR | OPf_KIDS | OPf_REF;
8201 enter->op_flags |= OPf_STACKED;
8202 }
8203
ef3e5ea9
NC		 8204 /* We don't have control over who points to theirmark, so sacrifice
8205 ours. */
8206 theirmark->op_next = ourmark->op_next;
8207 theirmark->op_flags = ourmark->op_flags;
ce335f37 8208 ourlast->op_next = gvop ? gvop : (OP *) enter;
ef3e5ea9
NC		 8209 op_null(ourmark);
8210 op_null(o);
8211 enter->op_private |= OPpITER_REVERSED;
8212 iter->op_private |= OPpITER_REVERSED;
8213
8214 break;
8215 }
e26df76a
NC		 8216
8217 case OP_SASSIGN: {
8218 OP *rv2gv;
8219 UNOP *refgen, *rv2cv;
8220 LISTOP *exlist;
8221
8222 /* I do not understand this, but if o->op_opt isn't set to 1,
8223 various tests in ext/B/t/bytecode.t fail with no readily
8224 apparent cause. */
8225
8226 o->op_opt = 1;
8227
de3370bc
NC		 8228
8229 if ((o->op_flags && OPf_WANT) != OPf_WANT_VOID)
8230 break;
8231
e26df76a
NC		 8232 if ((o->op_private & ~OPpASSIGN_BACKWARDS) != 2)
8233 break;
8234
8235 rv2gv = ((BINOP *)o)->op_last;
8236 if (!rv2gv || rv2gv->op_type != OP_RV2GV)
8237 break;
8238
8239 refgen = (UNOP *)((BINOP *)o)->op_first;
8240
8241 if (!refgen || refgen->op_type != OP_REFGEN)
8242 break;
8243
8244 exlist = (LISTOP *)refgen->op_first;
8245 if (!exlist || exlist->op_type != OP_NULL
8246 || exlist->op_targ != OP_LIST)
8247 break;
8248
8249 if (exlist->op_first->op_type != OP_PUSHMARK)
8250 break;
8251
8252 rv2cv = (UNOP*)exlist->op_last;
8253
8254 if (rv2cv->op_type != OP_RV2CV)
8255 break;
8256
8257 assert ((rv2gv->op_private & OPpDONT_INIT_GV) == 0);
8258 assert ((o->op_private & OPpASSIGN_CV_TO_GV) == 0);
8259 assert ((rv2cv->op_private & OPpMAY_RETURN_CONSTANT) == 0);
8260
8261 o->op_private |= OPpASSIGN_CV_TO_GV;
8262 rv2gv->op_private |= OPpDONT_INIT_GV;
8263 rv2cv->op_private |= OPpMAY_RETURN_CONSTANT;
8264
8265 break;
8266 }
8267
fe1bc4cf 8268
79072805 8269 default:
2814eb74 8270 o->op_opt = 1;
79072805
LW		 8271 break;
8272 }
a0d0e21e 8273 oldop = o;
79072805 8274 }
a0d0e21e 8275 LEAVE;
79072805 8276}
beab0874 8277
1cb0ed9b
RGS		 8278char*
8279Perl_custom_op_name(pTHX_ const OP* o)
53e06cf0 8280{
97aff369 8281 dVAR;
e1ec3a88 8282 const IV index = PTR2IV(o->op_ppaddr);
53e06cf0
SC		 8283 SV* keysv;
8284 HE* he;
8285
8286 if (!PL_custom_op_names) /* This probably shouldn't happen */
27da23d5 8287 return (char *)PL_op_name[OP_CUSTOM];
53e06cf0
SC		 8288
8289 keysv = sv_2mortal(newSViv(index));
8290
8291 he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0);
8292 if (!he)
27da23d5 8293 return (char *)PL_op_name[OP_CUSTOM]; /* Don't know who you are */
53e06cf0
SC		 8294
8295 return SvPV_nolen(HeVAL(he));
8296}
8297
1cb0ed9b
RGS		 8298char*
8299Perl_custom_op_desc(pTHX_ const OP* o)
53e06cf0 8300{
97aff369 8301 dVAR;
e1ec3a88 8302 const IV index = PTR2IV(o->op_ppaddr);
53e06cf0
SC		 8303 SV* keysv;
8304 HE* he;
8305
8306 if (!PL_custom_op_descs)
27da23d5 8307 return (char *)PL_op_desc[OP_CUSTOM];
53e06cf0
SC		 8308
8309 keysv = sv_2mortal(newSViv(index));
8310
8311 he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0);
8312 if (!he)
27da23d5 8313 return (char *)PL_op_desc[OP_CUSTOM];
53e06cf0
SC		 8314
8315 return SvPV_nolen(HeVAL(he));
8316}
19e8ce8e 8317
beab0874
JT		 8318#include "XSUB.h"
8319
8320/* Efficient sub that returns a constant scalar value. */
8321static void
acfe0abc 8322const_sv_xsub(pTHX_ CV* cv)
beab0874 8323{
97aff369 8324 dVAR;
beab0874 8325 dXSARGS;
9cbac4c7 8326 if (items != 0) {
6f207bd3 8327 NOOP;
9cbac4c7
DM		 8328#if 0
8329 Perl_croak(aTHX_ "usage: %s::%s()",
bfcb3514 8330 HvNAME_get(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)));
9cbac4c7
DM		 8331#endif
8332 }
9a049f1c 8333 EXTEND(sp, 1);
0768512c 8334 ST(0) = (SV*)XSANY.any_ptr;
beab0874
JT		 8335 XSRETURN(1);
8336}
4946a0fa
NC		 8337
8338/*
8339 * Local variables:
8340 * c-indentation-style: bsd
8341 * c-basic-offset: 4
8342 * indent-tabs-mode: t
8343 * End:
8344 *
37442d52
RGS		 8345 * ex: set ts=8 sts=4 sw=4 noet:
8346 */
Unnamed repository; edit this file 'description' to name the repository.