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