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