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