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