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
perlio.c: false Coverity finding (it cannot see that two pointers are the same):...
[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;
de5e01c2 2145 SV *sv = NULL;
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
de5e01c2 2246 assert(sv);
79072805 2247 if (type == OP_RV2GV)
eb8433b7
NC		 2248 newop = newGVOP(OP_GV, 0, (GV*)sv);
2249 else
2250 newop = newSVOP(OP_CONST, 0, sv);
2251 op_getmad(o,newop,'f');
2252 return newop;
aeea060c 2253
b7f7fd0b 2254 nope:
79072805
LW		 2255 return o;
2256}
2257
2258OP *
864dbfa3 2259Perl_gen_constant_list(pTHX_ register OP *o)
79072805 2260{
27da23d5 2261 dVAR;
79072805 2262 register OP *curop;
6867be6d 2263 const I32 oldtmps_floor = PL_tmps_floor;
79072805 2264
a0d0e21e 2265 list(o);
3280af22 2266 if (PL_error_count)
a0d0e21e
LW		 2267 return o; /* Don't attempt to run with errors */
2268
533c011a 2269 PL_op = curop = LINKLIST(o);
a0d0e21e 2270 o->op_next = 0;
a2efc822 2271 CALL_PEEP(curop);
cea2e8a9
GS		 2272 pp_pushmark();
2273 CALLRUNOPS(aTHX);
533c011a 2274 PL_op = curop;
cea2e8a9 2275 pp_anonlist();
3280af22 2276 PL_tmps_floor = oldtmps_floor;
79072805
LW		 2277
2278 o->op_type = OP_RV2AV;
22c35a8c 2279 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
fb53bbb2
SG		 2280 o->op_flags &= ~OPf_REF; /* treat \(1..2) like an ordinary list */
2281 o->op_flags |= OPf_PARENS; /* and flatten \(1..2,3) */
2814eb74 2282 o->op_opt = 0; /* needs to be revisited in peep() */
79072805 2283 curop = ((UNOP*)o)->op_first;
b37c2d43 2284 ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, SvREFCNT_inc_NN(*PL_stack_sp--));
eb8433b7
NC		 2285#ifdef PERL_MAD
2286 op_getmad(curop,o,'O');
2287#else
79072805 2288 op_free(curop);
eb8433b7 2289#endif
79072805
LW		 2290 linklist(o);
2291 return list(o);
2292}
2293
2294OP *
864dbfa3 2295Perl_convert(pTHX_ I32 type, I32 flags, OP *o)
79072805 2296{
27da23d5 2297 dVAR;
11343788 2298 if (!o || o->op_type != OP_LIST)
5f66b61c 2299 o = newLISTOP(OP_LIST, 0, o, NULL);
748a9306 2300 else
5dc0d613 2301 o->op_flags &= ~OPf_WANT;
79072805 2302
22c35a8c 2303 if (!(PL_opargs[type] & OA_MARK))
93c66552 2304 op_null(cLISTOPo->op_first);
8990e307 2305
eb160463 2306 o->op_type = (OPCODE)type;
22c35a8c 2307 o->op_ppaddr = PL_ppaddr[type];
11343788 2308 o->op_flags |= flags;
79072805 2309
11343788 2310 o = CHECKOP(type, o);
fe2774ed 2311 if (o->op_type != (unsigned)type)
11343788 2312 return o;
79072805 2313
11343788 2314 return fold_constants(o);
79072805
LW		 2315}
2316
2317/* List constructors */
2318
2319OP *
864dbfa3 2320Perl_append_elem(pTHX_ I32 type, OP *first, OP *last)
79072805
LW		 2321{
2322 if (!first)
2323 return last;
8990e307
LW		 2324
2325 if (!last)
79072805 2326 return first;
8990e307 2327
fe2774ed 2328 if (first->op_type != (unsigned)type
155aba94
GS		 2329 || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
2330 {
2331 return newLISTOP(type, 0, first, last);
2332 }
79072805 2333
a0d0e21e
LW		 2334 if (first->op_flags & OPf_KIDS)
2335 ((LISTOP*)first)->op_last->op_sibling = last;
2336 else {
2337 first->op_flags |= OPf_KIDS;
2338 ((LISTOP*)first)->op_first = last;
2339 }
2340 ((LISTOP*)first)->op_last = last;
a0d0e21e 2341 return first;
79072805
LW		 2342}
2343
2344OP *
864dbfa3 2345Perl_append_list(pTHX_ I32 type, LISTOP *first, LISTOP *last)
79072805
LW		 2346{
2347 if (!first)
2348 return (OP*)last;
8990e307
LW		 2349
2350 if (!last)
79072805 2351 return (OP*)first;
8990e307 2352
fe2774ed 2353 if (first->op_type != (unsigned)type)
79072805 2354 return prepend_elem(type, (OP*)first, (OP*)last);
8990e307 2355
fe2774ed 2356 if (last->op_type != (unsigned)type)
79072805
LW		 2357 return append_elem(type, (OP*)first, (OP*)last);
2358
2359 first->op_last->op_sibling = last->op_first;
2360 first->op_last = last->op_last;
117dada2 2361 first->op_flags |= (last->op_flags & OPf_KIDS);
1c846c1f 2362
eb8433b7
NC		 2363#ifdef PERL_MAD
2364 if (last->op_first && first->op_madprop) {
2365 MADPROP *mp = last->op_first->op_madprop;
2366 if (mp) {
2367 while (mp->mad_next)
2368 mp = mp->mad_next;
2369 mp->mad_next = first->op_madprop;
2370 }
2371 else {
2372 last->op_first->op_madprop = first->op_madprop;
2373 }
2374 }
2375 first->op_madprop = last->op_madprop;
2376 last->op_madprop = 0;
2377#endif
2378
238a4c30
NIS		 2379 FreeOp(last);
2380
79072805
LW		 2381 return (OP*)first;
2382}
2383
2384OP *
864dbfa3 2385Perl_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
79072805
LW		 2386{
2387 if (!first)
2388 return last;
8990e307
LW		 2389
2390 if (!last)
79072805 2391 return first;
8990e307 2392
fe2774ed 2393 if (last->op_type == (unsigned)type) {
8990e307
LW		 2394 if (type == OP_LIST) { /* already a PUSHMARK there */
2395 first->op_sibling = ((LISTOP*)last)->op_first->op_sibling;
2396 ((LISTOP*)last)->op_first->op_sibling = first;
36a5d4ba
DC		 2397 if (!(first->op_flags & OPf_PARENS))
2398 last->op_flags &= ~OPf_PARENS;
8990e307
LW		 2399 }
2400 else {
2401 if (!(last->op_flags & OPf_KIDS)) {
2402 ((LISTOP*)last)->op_last = first;
2403 last->op_flags |= OPf_KIDS;
2404 }
2405 first->op_sibling = ((LISTOP*)last)->op_first;
2406 ((LISTOP*)last)->op_first = first;
79072805 2407 }
117dada2 2408 last->op_flags |= OPf_KIDS;
79072805
LW		 2409 return last;
2410 }
2411
2412 return newLISTOP(type, 0, first, last);
2413}
2414
2415/* Constructors */
2416
eb8433b7
NC		 2417#ifdef PERL_MAD
2418
2419TOKEN *
2420Perl_newTOKEN(pTHX_ I32 optype, YYSTYPE lval, MADPROP* madprop)
2421{
2422 TOKEN *tk;
99129197 2423 Newxz(tk, 1, TOKEN);
eb8433b7
NC		 2424 tk->tk_type = (OPCODE)optype;
2425 tk->tk_type = 12345;
2426 tk->tk_lval = lval;
2427 tk->tk_mad = madprop;
2428 return tk;
2429}
2430
2431void
2432Perl_token_free(pTHX_ TOKEN* tk)
2433{
2434 if (tk->tk_type != 12345)
2435 return;
2436 mad_free(tk->tk_mad);
2437 Safefree(tk);
2438}
2439
2440void
2441Perl_token_getmad(pTHX_ TOKEN* tk, OP* o, char slot)
2442{
2443 MADPROP* mp;
2444 MADPROP* tm;
2445 if (tk->tk_type != 12345) {
2446 Perl_warner(aTHX_ packWARN(WARN_MISC),
2447 "Invalid TOKEN object ignored");
2448 return;
2449 }
2450 tm = tk->tk_mad;
2451 if (!tm)
2452 return;
2453
2454 /* faked up qw list? */
2455 if (slot == '(' &&
2456 tm->mad_type == MAD_SV &&
2457 SvPVX((SV*)tm->mad_val)[0] == 'q')
2458 slot = 'x';
2459
2460 if (o) {
2461 mp = o->op_madprop;
2462 if (mp) {
2463 for (;;) {
2464 /* pretend constant fold didn't happen? */
2465 if (mp->mad_key == 'f' &&
2466 (o->op_type == OP_CONST ||
2467 o->op_type == OP_GV) )
2468 {
2469 token_getmad(tk,(OP*)mp->mad_val,slot);
2470 return;
2471 }
2472 if (!mp->mad_next)
2473 break;
2474 mp = mp->mad_next;
2475 }
2476 mp->mad_next = tm;
2477 mp = mp->mad_next;
2478 }
2479 else {
2480 o->op_madprop = tm;
2481 mp = o->op_madprop;
2482 }
2483 if (mp->mad_key == 'X')
2484 mp->mad_key = slot; /* just change the first one */
2485
2486 tk->tk_mad = 0;
2487 }
2488 else
2489 mad_free(tm);
2490 Safefree(tk);
2491}
2492
2493void
2494Perl_op_getmad_weak(pTHX_ OP* from, OP* o, char slot)
2495{
2496 MADPROP* mp;
2497 if (!from)
2498 return;
2499 if (o) {
2500 mp = o->op_madprop;
2501 if (mp) {
2502 for (;;) {
2503 /* pretend constant fold didn't happen? */
2504 if (mp->mad_key == 'f' &&
2505 (o->op_type == OP_CONST ||
2506 o->op_type == OP_GV) )
2507 {
2508 op_getmad(from,(OP*)mp->mad_val,slot);
2509 return;
2510 }
2511 if (!mp->mad_next)
2512 break;
2513 mp = mp->mad_next;
2514 }
2515 mp->mad_next = newMADPROP(slot,MAD_OP,from,0);
2516 }
2517 else {
2518 o->op_madprop = newMADPROP(slot,MAD_OP,from,0);
2519 }
2520 }
2521}
2522
2523void
2524Perl_op_getmad(pTHX_ OP* from, OP* o, char slot)
2525{
2526 MADPROP* mp;
2527 if (!from)
2528 return;
2529 if (o) {
2530 mp = o->op_madprop;
2531 if (mp) {
2532 for (;;) {
2533 /* pretend constant fold didn't happen? */
2534 if (mp->mad_key == 'f' &&
2535 (o->op_type == OP_CONST ||
2536 o->op_type == OP_GV) )
2537 {
2538 op_getmad(from,(OP*)mp->mad_val,slot);
2539 return;
2540 }
2541 if (!mp->mad_next)
2542 break;
2543 mp = mp->mad_next;
2544 }
2545 mp->mad_next = newMADPROP(slot,MAD_OP,from,1);
2546 }
2547 else {
2548 o->op_madprop = newMADPROP(slot,MAD_OP,from,1);
2549 }
2550 }
2551 else {
99129197
NC		 2552 PerlIO_printf(PerlIO_stderr(),
2553 "DESTROYING op = %0"UVxf"\n", PTR2UV(from));
eb8433b7
NC		 2554 op_free(from);
2555 }
2556}
2557
2558void
2559Perl_prepend_madprops(pTHX_ MADPROP* mp, OP* o, char slot)
2560{
2561 MADPROP* tm;
2562 if (!mp || !o)
2563 return;
2564 if (slot)
2565 mp->mad_key = slot;
2566 tm = o->op_madprop;
2567 o->op_madprop = mp;
2568 for (;;) {
2569 if (!mp->mad_next)
2570 break;
2571 mp = mp->mad_next;
2572 }
2573 mp->mad_next = tm;
2574}
2575
2576void
2577Perl_append_madprops(pTHX_ MADPROP* tm, OP* o, char slot)
2578{
2579 if (!o)
2580 return;
2581 addmad(tm, &(o->op_madprop), slot);
2582}
2583
2584void
2585Perl_addmad(pTHX_ MADPROP* tm, MADPROP** root, char slot)
2586{
2587 MADPROP* mp;
2588 if (!tm || !root)
2589 return;
2590 if (slot)
2591 tm->mad_key = slot;
2592 mp = *root;
2593 if (!mp) {
2594 *root = tm;
2595 return;
2596 }
2597 for (;;) {
2598 if (!mp->mad_next)
2599 break;
2600 mp = mp->mad_next;
2601 }
2602 mp->mad_next = tm;
2603}
2604
2605MADPROP *
2606Perl_newMADsv(pTHX_ char key, SV* sv)
2607{
2608 return newMADPROP(key, MAD_SV, sv, 0);
2609}
2610
2611MADPROP *
2612Perl_newMADPROP(pTHX_ char key, char type, void* val, I32 vlen)
2613{
2614 MADPROP *mp;
99129197 2615 Newxz(mp, 1, MADPROP);
eb8433b7
NC		 2616 mp->mad_next = 0;
2617 mp->mad_key = key;
2618 mp->mad_vlen = vlen;
2619 mp->mad_type = type;
2620 mp->mad_val = val;
2621/* PerlIO_printf(PerlIO_stderr(), "NEW mp = %0x\n", mp); */
2622 return mp;
2623}
2624
2625void
2626Perl_mad_free(pTHX_ MADPROP* mp)
2627{
2628/* PerlIO_printf(PerlIO_stderr(), "FREE mp = %0x\n", mp); */
2629 if (!mp)
2630 return;
2631 if (mp->mad_next)
2632 mad_free(mp->mad_next);
2633/* if (PL_lex_state != LEX_NOTPARSING && mp->mad_vlen)
2634 PerlIO_printf(PerlIO_stderr(), "DESTROYING '%c'=<%s>\n", mp->mad_key & 255, mp->mad_val); */
2635 switch (mp->mad_type) {
2636 case MAD_NULL:
2637 break;
2638 case MAD_PV:
2639 Safefree((char*)mp->mad_val);
2640 break;
2641 case MAD_OP:
2642 if (mp->mad_vlen) /* vlen holds "strong/weak" boolean */
2643 op_free((OP*)mp->mad_val);
2644 break;
2645 case MAD_SV:
2646 sv_free((SV*)mp->mad_val);
2647 break;
2648 default:
2649 PerlIO_printf(PerlIO_stderr(), "Unrecognized mad\n");
2650 break;
2651 }
2652 Safefree(mp);
2653}
2654
2655#endif
2656
79072805 2657OP *
864dbfa3 2658Perl_newNULLLIST(pTHX)
79072805 2659{
8990e307
LW		 2660 return newOP(OP_STUB, 0);
2661}
2662
2663OP *
864dbfa3 2664Perl_force_list(pTHX_ OP *o)
8990e307 2665{
11343788 2666 if (!o || o->op_type != OP_LIST)
5f66b61c 2667 o = newLISTOP(OP_LIST, 0, o, NULL);
93c66552 2668 op_null(o);
11343788 2669 return o;
79072805
LW		 2670}
2671
2672OP *
864dbfa3 2673Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
79072805 2674{
27da23d5 2675 dVAR;
79072805
LW		 2676 LISTOP *listop;
2677
b7dc083c 2678 NewOp(1101, listop, 1, LISTOP);
79072805 2679
eb160463 2680 listop->op_type = (OPCODE)type;
22c35a8c 2681 listop->op_ppaddr = PL_ppaddr[type];
117dada2
SM		 2682 if (first || last)
2683 flags |= OPf_KIDS;
eb160463 2684 listop->op_flags = (U8)flags;
79072805
LW		 2685
2686 if (!last && first)
2687 last = first;
2688 else if (!first && last)
2689 first = last;
8990e307
LW		 2690 else if (first)
2691 first->op_sibling = last;
79072805
LW		 2692 listop->op_first = first;
2693 listop->op_last = last;
8990e307 2694 if (type == OP_LIST) {
551405c4 2695 OP* const pushop = newOP(OP_PUSHMARK, 0);
8990e307
LW		 2696 pushop->op_sibling = first;
2697 listop->op_first = pushop;
2698 listop->op_flags |= OPf_KIDS;
2699 if (!last)
2700 listop->op_last = pushop;
2701 }
79072805 2702
463d09e6 2703 return CHECKOP(type, listop);
79072805
LW		 2704}
2705
2706OP *
864dbfa3 2707Perl_newOP(pTHX_ I32 type, I32 flags)
79072805 2708{
27da23d5 2709 dVAR;
11343788 2710 OP *o;
b7dc083c 2711 NewOp(1101, o, 1, OP);
eb160463 2712 o->op_type = (OPCODE)type;
22c35a8c 2713 o->op_ppaddr = PL_ppaddr[type];
eb160463 2714 o->op_flags = (U8)flags;
79072805 2715
11343788 2716 o->op_next = o;
eb160463 2717 o->op_private = (U8)(0 | (flags >> 8));
22c35a8c 2718 if (PL_opargs[type] & OA_RETSCALAR)
11343788 2719 scalar(o);
22c35a8c 2720 if (PL_opargs[type] & OA_TARGET)
11343788
MB		 2721 o->op_targ = pad_alloc(type, SVs_PADTMP);
2722 return CHECKOP(type, o);
79072805
LW		 2723}
2724
2725OP *
864dbfa3 2726Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
79072805 2727{
27da23d5 2728 dVAR;
79072805
LW		 2729 UNOP *unop;
2730
93a17b20 2731 if (!first)
aeea060c 2732 first = newOP(OP_STUB, 0);
22c35a8c 2733 if (PL_opargs[type] & OA_MARK)
8990e307 2734 first = force_list(first);
93a17b20 2735
b7dc083c 2736 NewOp(1101, unop, 1, UNOP);
eb160463 2737 unop->op_type = (OPCODE)type;
22c35a8c 2738 unop->op_ppaddr = PL_ppaddr[type];
79072805 2739 unop->op_first = first;
585ec06d 2740 unop->op_flags = (U8)(flags | OPf_KIDS);
eb160463 2741 unop->op_private = (U8)(1 | (flags >> 8));
e50aee73 2742 unop = (UNOP*) CHECKOP(type, unop);
79072805
LW		 2743 if (unop->op_next)
2744 return (OP*)unop;
2745
a0d0e21e 2746 return fold_constants((OP *) unop);
79072805
LW		 2747}
2748
2749OP *
864dbfa3 2750Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
79072805 2751{
27da23d5 2752 dVAR;
79072805 2753 BINOP *binop;
b7dc083c 2754 NewOp(1101, binop, 1, BINOP);
79072805
LW		 2755
2756 if (!first)
2757 first = newOP(OP_NULL, 0);
2758
eb160463 2759 binop->op_type = (OPCODE)type;
22c35a8c 2760 binop->op_ppaddr = PL_ppaddr[type];
79072805 2761 binop->op_first = first;
585ec06d 2762 binop->op_flags = (U8)(flags | OPf_KIDS);
79072805
LW		 2763 if (!last) {
2764 last = first;
eb160463 2765 binop->op_private = (U8)(1 | (flags >> 8));
79072805
LW		 2766 }
2767 else {
eb160463 2768 binop->op_private = (U8)(2 | (flags >> 8));
79072805
LW		 2769 first->op_sibling = last;
2770 }
2771
e50aee73 2772 binop = (BINOP*)CHECKOP(type, binop);
eb160463 2773 if (binop->op_next || binop->op_type != (OPCODE)type)
79072805
LW		 2774 return (OP*)binop;
2775
7284ab6f 2776 binop->op_last = binop->op_first->op_sibling;
79072805 2777
a0d0e21e 2778 return fold_constants((OP *)binop);
79072805
LW		 2779}
2780
5f66b61c
AL		 2781static int uvcompare(const void *a, const void *b)
2782 __attribute__nonnull__(1)
2783 __attribute__nonnull__(2)
2784 __attribute__pure__;
abb2c242 2785static int uvcompare(const void *a, const void *b)
2b9d42f0 2786{
e1ec3a88 2787 if (*((const UV *)a) < (*(const UV *)b))
2b9d42f0 2788 return -1;
e1ec3a88 2789 if (*((const UV *)a) > (*(const UV *)b))
2b9d42f0 2790 return 1;
e1ec3a88 2791 if (*((const UV *)a+1) < (*(const UV *)b+1))
2b9d42f0 2792 return -1;
e1ec3a88 2793 if (*((const UV *)a+1) > (*(const UV *)b+1))
2b9d42f0 2794 return 1;
a0ed51b3
LW		 2795 return 0;
2796}
2797
79072805 2798OP *
864dbfa3 2799Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
79072805 2800{
97aff369 2801 dVAR;
2d03de9c
AL		 2802 SV * const tstr = ((SVOP*)expr)->op_sv;
2803 SV * const rstr = ((SVOP*)repl)->op_sv;
463ee0b2
LW		 2804 STRLEN tlen;
2805 STRLEN rlen;
5c144d81
NC		 2806 const U8 *t = (U8*)SvPV_const(tstr, tlen);
2807 const U8 *r = (U8*)SvPV_const(rstr, rlen);
79072805
LW		 2808 register I32 i;
2809 register I32 j;
9b877dbb 2810 I32 grows = 0;
79072805
LW		 2811 register short *tbl;
2812
551405c4
AL		 2813 const I32 complement = o->op_private & OPpTRANS_COMPLEMENT;
2814 const I32 squash = o->op_private & OPpTRANS_SQUASH;
2815 I32 del = o->op_private & OPpTRANS_DELETE;
800b4dc4 2816 PL_hints |= HINT_BLOCK_SCOPE;
1c846c1f 2817
036b4402
GS		 2818 if (SvUTF8(tstr))
2819 o->op_private |= OPpTRANS_FROM_UTF;
1c846c1f
NIS		 2820
2821 if (SvUTF8(rstr))
036b4402 2822 o->op_private |= OPpTRANS_TO_UTF;
79072805 2823
a0ed51b3 2824 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
396482e1 2825 SV* const listsv = newSVpvs("# comment\n");
c445ea15 2826 SV* transv = NULL;
5c144d81
NC		 2827 const U8* tend = t + tlen;
2828 const U8* rend = r + rlen;
ba210ebe 2829 STRLEN ulen;
84c133a0
RB		 2830 UV tfirst = 1;
2831 UV tlast = 0;
2832 IV tdiff;
2833 UV rfirst = 1;
2834 UV rlast = 0;
2835 IV rdiff;
2836 IV diff;
a0ed51b3
LW		 2837 I32 none = 0;
2838 U32 max = 0;
2839 I32 bits;
a0ed51b3 2840 I32 havefinal = 0;
9c5ffd7c 2841 U32 final = 0;
551405c4
AL		 2842 const I32 from_utf = o->op_private & OPpTRANS_FROM_UTF;
2843 const I32 to_utf = o->op_private & OPpTRANS_TO_UTF;
bf4a1e57
JH		 2844 U8* tsave = NULL;
2845 U8* rsave = NULL;
9f7f3913 2846 const U32 flags = UTF8_ALLOW_DEFAULT;
bf4a1e57
JH		 2847
2848 if (!from_utf) {
2849 STRLEN len = tlen;
5c144d81 2850 t = tsave = bytes_to_utf8(t, &len);
bf4a1e57
JH		 2851 tend = t + len;
2852 }
2853 if (!to_utf && rlen) {
2854 STRLEN len = rlen;
5c144d81 2855 r = rsave = bytes_to_utf8(r, &len);
bf4a1e57
JH		 2856 rend = r + len;
2857 }
a0ed51b3 2858
2b9d42f0
NIS		 2859/* There are several snags with this code on EBCDIC:
2860 1. 0xFF is a legal UTF-EBCDIC byte (there are no illegal bytes).
2861 2. scan_const() in toke.c has encoded chars in native encoding which makes
2862 ranges at least in EBCDIC 0..255 range the bottom odd.
2863*/
2864
a0ed51b3 2865 if (complement) {
89ebb4a3 2866 U8 tmpbuf[UTF8_MAXBYTES+1];
2b9d42f0 2867 UV *cp;
a0ed51b3 2868 UV nextmin = 0;
a02a5408 2869 Newx(cp, 2*tlen, UV);
a0ed51b3 2870 i = 0;
396482e1 2871 transv = newSVpvs("");
a0ed51b3 2872 while (t < tend) {
9f7f3913 2873 cp[2*i] = utf8n_to_uvuni(t, tend-t, &ulen, flags);
2b9d42f0
NIS		 2874 t += ulen;
2875 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) {
a0ed51b3 2876 t++;
9f7f3913 2877 cp[2*i+1] = utf8n_to_uvuni(t, tend-t, &ulen, flags);
2b9d42f0 2878 t += ulen;
a0ed51b3 2879 }
2b9d42f0
NIS		 2880 else {
2881 cp[2*i+1] = cp[2*i];
2882 }
2883 i++;
a0ed51b3 2884 }
2b9d42f0 2885 qsort(cp, i, 2*sizeof(UV), uvcompare);
a0ed51b3 2886 for (j = 0; j < i; j++) {
2b9d42f0 2887 UV val = cp[2*j];
a0ed51b3
LW		 2888 diff = val - nextmin;
2889 if (diff > 0) {
9041c2e3 2890 t = uvuni_to_utf8(tmpbuf,nextmin);
dfe13c55 2891 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
a0ed51b3 2892 if (diff > 1) {
2b9d42f0 2893 U8 range_mark = UTF_TO_NATIVE(0xff);
9041c2e3 2894 t = uvuni_to_utf8(tmpbuf, val - 1);
2b9d42f0 2895 sv_catpvn(transv, (char *)&range_mark, 1);
dfe13c55 2896 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
a0ed51b3
LW		 2897 }
2898 }
2b9d42f0 2899 val = cp[2*j+1];
a0ed51b3
LW		 2900 if (val >= nextmin)
2901 nextmin = val + 1;
2902 }
9041c2e3 2903 t = uvuni_to_utf8(tmpbuf,nextmin);
dfe13c55 2904 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2b9d42f0
NIS		 2905 {
2906 U8 range_mark = UTF_TO_NATIVE(0xff);
2907 sv_catpvn(transv, (char *)&range_mark, 1);
2908 }
b851fbc1
JH		 2909 t = uvuni_to_utf8_flags(tmpbuf, 0x7fffffff,
2910 UNICODE_ALLOW_SUPER);
dfe13c55 2911 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
93524f2b 2912 t = (const U8*)SvPVX_const(transv);
a0ed51b3
LW		 2913 tlen = SvCUR(transv);
2914 tend = t + tlen;
455d824a 2915 Safefree(cp);
a0ed51b3
LW		 2916 }
2917 else if (!rlen && !del) {
2918 r = t; rlen = tlen; rend = tend;
4757a243
LW		 2919 }
2920 if (!squash) {
05d340b8 2921 if ((!rlen && !del) || t == r ||
12ae5dfc 2922 (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
01ec43d0 2923 {
4757a243 2924 o->op_private |= OPpTRANS_IDENTICAL;
01ec43d0 2925 }
a0ed51b3
LW		 2926 }
2927
2928 while (t < tend || tfirst <= tlast) {
2929 /* see if we need more "t" chars */
2930 if (tfirst > tlast) {
9f7f3913 2931 tfirst = (I32)utf8n_to_uvuni(t, tend - t, &ulen, flags);
a0ed51b3 2932 t += ulen;
2b9d42f0 2933 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) { /* illegal utf8 val indicates range */
ba210ebe 2934 t++;
9f7f3913 2935 tlast = (I32)utf8n_to_uvuni(t, tend - t, &ulen, flags);
a0ed51b3
LW		 2936 t += ulen;
2937 }
2938 else
2939 tlast = tfirst;
2940 }
2941
2942 /* now see if we need more "r" chars */
2943 if (rfirst > rlast) {
2944 if (r < rend) {
9f7f3913 2945 rfirst = (I32)utf8n_to_uvuni(r, rend - r, &ulen, flags);
a0ed51b3 2946 r += ulen;
2b9d42f0 2947 if (r < rend && NATIVE_TO_UTF(*r) == 0xff) { /* illegal utf8 val indicates range */
ba210ebe 2948 r++;
9f7f3913 2949 rlast = (I32)utf8n_to_uvuni(r, rend - r, &ulen, flags);
a0ed51b3
LW		 2950 r += ulen;
2951 }
2952 else
2953 rlast = rfirst;
2954 }
2955 else {
2956 if (!havefinal++)
2957 final = rlast;
2958 rfirst = rlast = 0xffffffff;
2959 }
2960 }
2961
2962 /* now see which range will peter our first, if either. */
2963 tdiff = tlast - tfirst;
2964 rdiff = rlast - rfirst;
2965
2966 if (tdiff <= rdiff)
2967 diff = tdiff;
2968 else
2969 diff = rdiff;
2970
2971 if (rfirst == 0xffffffff) {
2972 diff = tdiff; /* oops, pretend rdiff is infinite */
2973 if (diff > 0)
894356b3
GS		 2974 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
2975 (long)tfirst, (long)tlast);
a0ed51b3 2976 else
894356b3 2977 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
a0ed51b3
LW		 2978 }
2979 else {
2980 if (diff > 0)
894356b3
GS		 2981 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
2982 (long)tfirst, (long)(tfirst + diff),
2983 (long)rfirst);
a0ed51b3 2984 else
894356b3
GS		 2985 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
2986 (long)tfirst, (long)rfirst);
a0ed51b3
LW		 2987
2988 if (rfirst + diff > max)
2989 max = rfirst + diff;
9b877dbb 2990 if (!grows)
45005bfb
JH		 2991 grows = (tfirst < rfirst &&
2992 UNISKIP(tfirst) < UNISKIP(rfirst + diff));
2993 rfirst += diff + 1;
a0ed51b3
LW		 2994 }
2995 tfirst += diff + 1;
2996 }
2997
2998 none = ++max;
2999 if (del)
3000 del = ++max;
3001
3002 if (max > 0xffff)
3003 bits = 32;
3004 else if (max > 0xff)
3005 bits = 16;
3006 else
3007 bits = 8;
3008
455d824a 3009 Safefree(cPVOPo->op_pv);
a0ed51b3
LW		 3010 cSVOPo->op_sv = (SV*)swash_init("utf8", "", listsv, bits, none);
3011 SvREFCNT_dec(listsv);
b37c2d43 3012 SvREFCNT_dec(transv);
a0ed51b3 3013
45005bfb 3014 if (!del && havefinal && rlen)
b448e4fe
JH		 3015 (void)hv_store((HV*)SvRV((cSVOPo->op_sv)), "FINAL", 5,
3016 newSVuv((UV)final), 0);
a0ed51b3 3017
9b877dbb 3018 if (grows)
a0ed51b3
LW		 3019 o->op_private |= OPpTRANS_GROWS;
3020
b37c2d43
AL		 3021 Safefree(tsave);
3022 Safefree(rsave);
9b877dbb 3023
eb8433b7
NC		 3024#ifdef PERL_MAD
3025 op_getmad(expr,o,'e');
3026 op_getmad(repl,o,'r');
3027#else
a0ed51b3
LW		 3028 op_free(expr);
3029 op_free(repl);
eb8433b7 3030#endif
a0ed51b3
LW		 3031 return o;
3032 }
3033
3034 tbl = (short*)cPVOPo->op_pv;
79072805
LW		 3035 if (complement) {
3036 Zero(tbl, 256, short);
eb160463 3037 for (i = 0; i < (I32)tlen; i++)
ec49126f 3038 tbl[t[i]] = -1;
79072805
LW		 3039 for (i = 0, j = 0; i < 256; i++) {
3040 if (!tbl[i]) {
eb160463 3041 if (j >= (I32)rlen) {
a0ed51b3 3042 if (del)
79072805
LW		 3043 tbl[i] = -2;
3044 else if (rlen)
ec49126f 3045 tbl[i] = r[j-1];
79072805 3046 else
eb160463 3047 tbl[i] = (short)i;
79072805 3048 }
9b877dbb
IH		 3049 else {
3050 if (i < 128 && r[j] >= 128)
3051 grows = 1;
ec49126f 3052 tbl[i] = r[j++];
9b877dbb 3053 }
79072805
LW		 3054 }
3055 }
05d340b8
JH		 3056 if (!del) {
3057 if (!rlen) {
3058 j = rlen;
3059 if (!squash)
3060 o->op_private |= OPpTRANS_IDENTICAL;
3061 }
eb160463 3062 else if (j >= (I32)rlen)
05d340b8
JH		 3063 j = rlen - 1;
3064 else
3065 cPVOPo->op_pv = (char*)Renew(tbl, 0x101+rlen-j, short);
585ec06d 3066 tbl[0x100] = (short)(rlen - j);
eb160463 3067 for (i=0; i < (I32)rlen - j; i++)
8973db79
JH		 3068 tbl[0x101+i] = r[j+i];
3069 }
79072805
LW		 3070 }
3071 else {
a0ed51b3 3072 if (!rlen && !del) {
79072805 3073 r = t; rlen = tlen;
5d06d08e 3074 if (!squash)
4757a243 3075 o->op_private |= OPpTRANS_IDENTICAL;
79072805 3076 }
94bfe852
RGS		 3077 else if (!squash && rlen == tlen && memEQ((char*)t, (char*)r, tlen)) {
3078 o->op_private |= OPpTRANS_IDENTICAL;
3079 }
79072805
LW		 3080 for (i = 0; i < 256; i++)
3081 tbl[i] = -1;
eb160463
GS		 3082 for (i = 0, j = 0; i < (I32)tlen; i++,j++) {
3083 if (j >= (I32)rlen) {
a0ed51b3 3084 if (del) {
ec49126f 3085 if (tbl[t[i]] == -1)
3086 tbl[t[i]] = -2;
79072805
LW		 3087 continue;
3088 }
3089 --j;
3090 }
9b877dbb
IH		 3091 if (tbl[t[i]] == -1) {
3092 if (t[i] < 128 && r[j] >= 128)
3093 grows = 1;
ec49126f 3094 tbl[t[i]] = r[j];
9b877dbb 3095 }
79072805
LW		 3096 }
3097 }
9b877dbb
IH		 3098 if (grows)
3099 o->op_private |= OPpTRANS_GROWS;
eb8433b7
NC		 3100#ifdef PERL_MAD
3101 op_getmad(expr,o,'e');
3102 op_getmad(repl,o,'r');
3103#else
79072805
LW		 3104 op_free(expr);
3105 op_free(repl);
eb8433b7 3106#endif
79072805 3107
11343788 3108 return o;
79072805
LW		 3109}
3110
3111OP *
864dbfa3 3112Perl_newPMOP(pTHX_ I32 type, I32 flags)
79072805 3113{
27da23d5 3114 dVAR;
79072805
LW		 3115 PMOP *pmop;
3116
b7dc083c 3117 NewOp(1101, pmop, 1, PMOP);
eb160463 3118 pmop->op_type = (OPCODE)type;
22c35a8c 3119 pmop->op_ppaddr = PL_ppaddr[type];
eb160463
GS		 3120 pmop->op_flags = (U8)flags;
3121 pmop->op_private = (U8)(0 | (flags >> 8));
79072805 3122
3280af22 3123 if (PL_hints & HINT_RE_TAINT)
b3eb6a9b 3124 pmop->op_pmpermflags |= PMf_RETAINT;
3280af22 3125 if (PL_hints & HINT_LOCALE)
b3eb6a9b
GS		 3126 pmop->op_pmpermflags |= PMf_LOCALE;
3127 pmop->op_pmflags = pmop->op_pmpermflags;
36477c24 3128
debc9467 3129#ifdef USE_ITHREADS
551405c4
AL		 3130 if (av_len((AV*) PL_regex_pad[0]) > -1) {
3131 SV * const repointer = av_pop((AV*)PL_regex_pad[0]);
3132 pmop->op_pmoffset = SvIV(repointer);
3133 SvREPADTMP_off(repointer);
3134 sv_setiv(repointer,0);
3135 } else {
3136 SV * const repointer = newSViv(0);
b37c2d43 3137 av_push(PL_regex_padav, SvREFCNT_inc_simple_NN(repointer));
551405c4
AL		 3138 pmop->op_pmoffset = av_len(PL_regex_padav);
3139 PL_regex_pad = AvARRAY(PL_regex_padav);
13137afc 3140 }
debc9467 3141#endif
1eb1540c 3142
1fcf4c12 3143 /* link into pm list */
3280af22 3144 if (type != OP_TRANS && PL_curstash) {
8d2f4536
NC		 3145 MAGIC *mg = mg_find((SV*)PL_curstash, PERL_MAGIC_symtab);
3146
3147 if (!mg) {
3148 mg = sv_magicext((SV*)PL_curstash, 0, PERL_MAGIC_symtab, 0, 0, 0);
3149 }
3150 pmop->op_pmnext = (PMOP*)mg->mg_obj;
3151 mg->mg_obj = (SV*)pmop;
cb55de95 3152 PmopSTASH_set(pmop,PL_curstash);
79072805
LW		 3153 }
3154
463d09e6 3155 return CHECKOP(type, pmop);
79072805
LW		 3156}
3157
131b3ad0
DM		 3158/* Given some sort of match op o, and an expression expr containing a
3159 * pattern, either compile expr into a regex and attach it to o (if it's
3160 * constant), or convert expr into a runtime regcomp op sequence (if it's
3161 * not)
3162 *
3163 * isreg indicates that the pattern is part of a regex construct, eg
3164 * $x =~ /pattern/ or split /pattern/, as opposed to $x =~ $pattern or
3165 * split "pattern", which aren't. In the former case, expr will be a list
3166 * if the pattern contains more than one term (eg /a$b/) or if it contains
3167 * a replacement, ie s/// or tr///.
3168 */
3169
79072805 3170OP *
131b3ad0 3171Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg)
79072805 3172{
27da23d5 3173 dVAR;
79072805
LW		 3174 PMOP *pm;
3175 LOGOP *rcop;
ce862d02 3176 I32 repl_has_vars = 0;
5f66b61c 3177 OP* repl = NULL;
131b3ad0
DM		 3178 bool reglist;
3179
3180 if (o->op_type == OP_SUBST || o->op_type == OP_TRANS) {
3181 /* last element in list is the replacement; pop it */
3182 OP* kid;
3183 repl = cLISTOPx(expr)->op_last;
3184 kid = cLISTOPx(expr)->op_first;
3185 while (kid->op_sibling != repl)
3186 kid = kid->op_sibling;
5f66b61c 3187 kid->op_sibling = NULL;
131b3ad0
DM		 3188 cLISTOPx(expr)->op_last = kid;
3189 }
79072805 3190
131b3ad0
DM		 3191 if (isreg && expr->op_type == OP_LIST &&
3192 cLISTOPx(expr)->op_first->op_sibling == cLISTOPx(expr)->op_last)
3193 {
3194 /* convert single element list to element */
0bd48802 3195 OP* const oe = expr;
131b3ad0 3196 expr = cLISTOPx(oe)->op_first->op_sibling;
5f66b61c
AL		 3197 cLISTOPx(oe)->op_first->op_sibling = NULL;
3198 cLISTOPx(oe)->op_last = NULL;
131b3ad0
DM		 3199 op_free(oe);
3200 }
3201
3202 if (o->op_type == OP_TRANS) {
11343788 3203 return pmtrans(o, expr, repl);
131b3ad0
DM		 3204 }
3205
3206 reglist = isreg && expr->op_type == OP_LIST;
3207 if (reglist)
3208 op_null(expr);
79072805 3209
3280af22 3210 PL_hints |= HINT_BLOCK_SCOPE;
11343788 3211 pm = (PMOP*)o;
79072805
LW		 3212
3213 if (expr->op_type == OP_CONST) {
463ee0b2 3214 STRLEN plen;
6136c704 3215 SV * const pat = ((SVOP*)expr)->op_sv;
5c144d81 3216 const char *p = SvPV_const(pat, plen);
770526c1 3217 if ((o->op_flags & OPf_SPECIAL) && (*p == ' ' && p[1] == '\0')) {
5c144d81
NC		 3218 U32 was_readonly = SvREADONLY(pat);
3219
3220 if (was_readonly) {
3221 if (SvFAKE(pat)) {
3222 sv_force_normal_flags(pat, 0);
3223 assert(!SvREADONLY(pat));
3224 was_readonly = 0;
3225 } else {
3226 SvREADONLY_off(pat);
3227 }
3228 }
3229
93a17b20 3230 sv_setpvn(pat, "\\s+", 3);
5c144d81
NC		 3231
3232 SvFLAGS(pat) |= was_readonly;
3233
3234 p = SvPV_const(pat, plen);
79072805
LW		 3235 pm->op_pmflags |= PMf_SKIPWHITE;
3236 }
5b71a6a7 3237 if (DO_UTF8(pat))
a5961de5 3238 pm->op_pmdynflags |= PMdf_UTF8;
5c144d81
NC		 3239 /* FIXME - can we make this function take const char * args? */
3240 PM_SETRE(pm, CALLREGCOMP(aTHX_ (char*)p, (char*)p + plen, pm));
aaa362c4 3241 if (strEQ("\\s+", PM_GETRE(pm)->precomp))
85e6fe83 3242 pm->op_pmflags |= PMf_WHITE;
eb8433b7
NC		 3243#ifdef PERL_MAD
3244 op_getmad(expr,(OP*)pm,'e');
3245#else
79072805 3246 op_free(expr);
eb8433b7 3247#endif
79072805
LW		 3248 }
3249 else {
3280af22 3250 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL))
1c846c1f 3251 expr = newUNOP((!(PL_hints & HINT_RE_EVAL)
2cd61cdb
IZ		 3252 ? OP_REGCRESET
3253 : OP_REGCMAYBE),0,expr);
463ee0b2 3254
b7dc083c 3255 NewOp(1101, rcop, 1, LOGOP);
79072805 3256 rcop->op_type = OP_REGCOMP;
22c35a8c 3257 rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP];
79072805 3258 rcop->op_first = scalar(expr);
131b3ad0
DM		 3259 rcop->op_flags |= OPf_KIDS
3260 | ((PL_hints & HINT_RE_EVAL) ? OPf_SPECIAL : 0)
3261 | (reglist ? OPf_STACKED : 0);
79072805 3262 rcop->op_private = 1;
11343788 3263 rcop->op_other = o;
131b3ad0
DM		 3264 if (reglist)
3265 rcop->op_targ = pad_alloc(rcop->op_type, SVs_PADTMP);
3266
b5c19bd7
DM		 3267 /* /$x/ may cause an eval, since $x might be qr/(?{..})/ */
3268 PL_cv_has_eval = 1;
79072805
LW		 3269
3270 /* establish postfix order */
3280af22 3271 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL)) {
463ee0b2
LW		 3272 LINKLIST(expr);
3273 rcop->op_next = expr;
3274 ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
3275 }
3276 else {
3277 rcop->op_next = LINKLIST(expr);
3278 expr->op_next = (OP*)rcop;
3279 }
79072805 3280
11343788 3281 prepend_elem(o->op_type, scalar((OP*)rcop), o);
79072805
LW		 3282 }
3283
3284 if (repl) {
748a9306 3285 OP *curop;
0244c3a4 3286 if (pm->op_pmflags & PMf_EVAL) {
6136c704 3287 curop = NULL;
8bafa735 3288 if (CopLINE(PL_curcop) < (line_t)PL_multi_end)
eb160463 3289 CopLINE_set(PL_curcop, (line_t)PL_multi_end);
0244c3a4 3290 }
748a9306
LW		 3291 else if (repl->op_type == OP_CONST)
3292 curop = repl;
79072805 3293 else {
c445ea15 3294 OP *lastop = NULL;
79072805 3295 for (curop = LINKLIST(repl); curop!=repl; curop = LINKLIST(curop)) {
22c35a8c 3296 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
79072805 3297 if (curop->op_type == OP_GV) {
6136c704 3298 GV * const gv = cGVOPx_gv(curop);
ce862d02 3299 repl_has_vars = 1;
f702bf4a 3300 if (strchr("&`'123456789+-\016\022", *GvENAME(gv)))
79072805
LW		 3301 break;
3302 }
3303 else if (curop->op_type == OP_RV2CV)
3304 break;
3305 else if (curop->op_type == OP_RV2SV ||
3306 curop->op_type == OP_RV2AV ||
3307 curop->op_type == OP_RV2HV ||
3308 curop->op_type == OP_RV2GV) {
3309 if (lastop && lastop->op_type != OP_GV) /*funny deref?*/
3310 break;
3311 }
748a9306
LW		 3312 else if (curop->op_type == OP_PADSV ||
3313 curop->op_type == OP_PADAV ||
3314 curop->op_type == OP_PADHV ||
554b3eca 3315 curop->op_type == OP_PADANY) {
ce862d02 3316 repl_has_vars = 1;
748a9306 3317 }
1167e5da 3318 else if (curop->op_type == OP_PUSHRE)
bb263b4e 3319 /*EMPTY*/; /* Okay here, dangerous in newASSIGNOP */
79072805
LW		 3320 else
3321 break;
3322 }
3323 lastop = curop;
3324 }
748a9306 3325 }
ce862d02 3326 if (curop == repl
1c846c1f 3327 && !(repl_has_vars
aaa362c4
RS		 3328 && (!PM_GETRE(pm)
3329 || PM_GETRE(pm)->reganch & ROPT_EVAL_SEEN))) {
748a9306 3330 pm->op_pmflags |= PMf_CONST; /* const for long enough */
4633a7c4 3331 pm->op_pmpermflags |= PMf_CONST; /* const for long enough */
11343788 3332 prepend_elem(o->op_type, scalar(repl), o);
748a9306
LW		 3333 }
3334 else {
aaa362c4 3335 if (curop == repl && !PM_GETRE(pm)) { /* Has variables. */
ce862d02
IZ		 3336 pm->op_pmflags |= PMf_MAYBE_CONST;
3337 pm->op_pmpermflags |= PMf_MAYBE_CONST;
3338 }
b7dc083c 3339 NewOp(1101, rcop, 1, LOGOP);
748a9306 3340 rcop->op_type = OP_SUBSTCONT;
22c35a8c 3341 rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT];
748a9306
LW		 3342 rcop->op_first = scalar(repl);
3343 rcop->op_flags |= OPf_KIDS;
3344 rcop->op_private = 1;
11343788 3345 rcop->op_other = o;
748a9306
LW		 3346
3347 /* establish postfix order */
3348 rcop->op_next = LINKLIST(repl);
3349 repl->op_next = (OP*)rcop;
3350
3351 pm->op_pmreplroot = scalar((OP*)rcop);
3352 pm->op_pmreplstart = LINKLIST(rcop);
3353 rcop->op_next = 0;
79072805
LW		 3354 }
3355 }
3356
3357 return (OP*)pm;
3358}
3359
3360OP *
864dbfa3 3361Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
79072805 3362{
27da23d5 3363 dVAR;
79072805 3364 SVOP *svop;
b7dc083c 3365 NewOp(1101, svop, 1, SVOP);
eb160463 3366 svop->op_type = (OPCODE)type;
22c35a8c 3367 svop->op_ppaddr = PL_ppaddr[type];
79072805
LW		 3368 svop->op_sv = sv;
3369 svop->op_next = (OP*)svop;
eb160463 3370 svop->op_flags = (U8)flags;
22c35a8c 3371 if (PL_opargs[type] & OA_RETSCALAR)
463ee0b2 3372 scalar((OP*)svop);
22c35a8c 3373 if (PL_opargs[type] & OA_TARGET)
ed6116ce 3374 svop->op_targ = pad_alloc(type, SVs_PADTMP);
e50aee73 3375 return CHECKOP(type, svop);
79072805
LW		 3376}
3377
3378OP *
350de78d
GS		 3379Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
3380{
27da23d5 3381 dVAR;
350de78d
GS		 3382 PADOP *padop;
3383 NewOp(1101, padop, 1, PADOP);
eb160463 3384 padop->op_type = (OPCODE)type;
350de78d
GS		 3385 padop->op_ppaddr = PL_ppaddr[type];
3386 padop->op_padix = pad_alloc(type, SVs_PADTMP);
dd2155a4
DM		 3387 SvREFCNT_dec(PAD_SVl(padop->op_padix));
3388 PAD_SETSV(padop->op_padix, sv);
ce50c033
AMS		 3389 if (sv)
3390 SvPADTMP_on(sv);
350de78d 3391 padop->op_next = (OP*)padop;
eb160463 3392 padop->op_flags = (U8)flags;
350de78d
GS		 3393 if (PL_opargs[type] & OA_RETSCALAR)
3394 scalar((OP*)padop);
3395 if (PL_opargs[type] & OA_TARGET)
3396 padop->op_targ = pad_alloc(type, SVs_PADTMP);
3397 return CHECKOP(type, padop);
3398}
3399
3400OP *
864dbfa3 3401Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
79072805 3402{
27da23d5 3403 dVAR;
350de78d 3404#ifdef USE_ITHREADS
ce50c033
AMS		 3405 if (gv)
3406 GvIN_PAD_on(gv);
b37c2d43 3407 return newPADOP(type, flags, SvREFCNT_inc_simple(gv));
350de78d 3408#else
b37c2d43 3409 return newSVOP(type, flags, SvREFCNT_inc_simple(gv));
350de78d 3410#endif
79072805
LW		 3411}
3412
3413OP *
864dbfa3 3414Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
79072805 3415{
27da23d5 3416 dVAR;
79072805 3417 PVOP *pvop;
b7dc083c 3418 NewOp(1101, pvop, 1, PVOP);
eb160463 3419 pvop->op_type = (OPCODE)type;
22c35a8c 3420 pvop->op_ppaddr = PL_ppaddr[type];
79072805
LW		 3421 pvop->op_pv = pv;
3422 pvop->op_next = (OP*)pvop;
eb160463 3423 pvop->op_flags = (U8)flags;
22c35a8c 3424 if (PL_opargs[type] & OA_RETSCALAR)
463ee0b2 3425 scalar((OP*)pvop);
22c35a8c 3426 if (PL_opargs[type] & OA_TARGET)
ed6116ce 3427 pvop->op_targ = pad_alloc(type, SVs_PADTMP);
e50aee73 3428 return CHECKOP(type, pvop);
79072805
LW		 3429}
3430
eb8433b7
NC		 3431#ifdef PERL_MAD
3432OP*
3433#else
79072805 3434void
eb8433b7 3435#endif
864dbfa3 3436Perl_package(pTHX_ OP *o)
79072805 3437{
97aff369 3438 dVAR;
6867be6d 3439 const char *name;
de11ba31 3440 STRLEN len;
eb8433b7
NC		 3441#ifdef PERL_MAD
3442 OP *pegop;
3443#endif
79072805 3444
3280af22
NIS		 3445 save_hptr(&PL_curstash);
3446 save_item(PL_curstname);
de11ba31 3447
5c144d81 3448 name = SvPV_const(cSVOPo->op_sv, len);
de11ba31
AMS		 3449 PL_curstash = gv_stashpvn(name, len, TRUE);
3450 sv_setpvn(PL_curstname, name, len);
de11ba31 3451
7ad382f4 3452 PL_hints |= HINT_BLOCK_SCOPE;
3280af22
NIS		 3453 PL_copline = NOLINE;
3454 PL_expect = XSTATE;
eb8433b7
NC		 3455
3456#ifndef PERL_MAD
3457 op_free(o);
3458#else
3459 if (!PL_madskills) {
3460 op_free(o);
1d866c12 3461 return NULL;
eb8433b7
NC		 3462 }
3463
3464 pegop = newOP(OP_NULL,0);
3465 op_getmad(o,pegop,'P');
3466 return pegop;
3467#endif
79072805
LW		 3468}
3469
eb8433b7
NC		 3470#ifdef PERL_MAD
3471OP*
3472#else
85e6fe83 3473void
eb8433b7 3474#endif
88d95a4d 3475Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg)
85e6fe83 3476{
97aff369 3477 dVAR;
a0d0e21e 3478 OP *pack;
a0d0e21e 3479 OP *imop;
b1cb66bf 3480 OP *veop;
eb8433b7
NC		 3481#ifdef PERL_MAD
3482 OP *pegop = newOP(OP_NULL,0);
3483#endif
85e6fe83 3484
88d95a4d 3485 if (idop->op_type != OP_CONST)
cea2e8a9 3486 Perl_croak(aTHX_ "Module name must be constant");
85e6fe83 3487
eb8433b7
NC		 3488 if (PL_madskills)
3489 op_getmad(idop,pegop,'U');
3490
5f66b61c 3491 veop = NULL;
b1cb66bf 3492
aec46f14 3493 if (version) {
551405c4 3494 SV * const vesv = ((SVOP*)version)->op_sv;
b1cb66bf 3495
eb8433b7
NC		 3496 if (PL_madskills)
3497 op_getmad(version,pegop,'V');
aec46f14 3498 if (!arg && !SvNIOKp(vesv)) {
b1cb66bf 3499 arg = version;
3500 }
3501 else {
3502 OP *pack;
0f79a09d 3503 SV *meth;
b1cb66bf 3504
44dcb63b 3505 if (version->op_type != OP_CONST || !SvNIOKp(vesv))
cea2e8a9 3506 Perl_croak(aTHX_ "Version number must be constant number");
b1cb66bf 3507
88d95a4d
JH		 3508 /* Make copy of idop so we don't free it twice */
3509 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
b1cb66bf 3510
3511 /* Fake up a method call to VERSION */
18916d0d 3512 meth = newSVpvs_share("VERSION");
b1cb66bf 3513 veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3514 append_elem(OP_LIST,
0f79a09d
GS		 3515 prepend_elem(OP_LIST, pack, list(version)),
3516 newSVOP(OP_METHOD_NAMED, 0, meth)));
b1cb66bf 3517 }
3518 }
aeea060c 3519
a0d0e21e 3520 /* Fake up an import/unimport */
eb8433b7
NC		 3521 if (arg && arg->op_type == OP_STUB) {
3522 if (PL_madskills)
3523 op_getmad(arg,pegop,'S');
4633a7c4 3524 imop = arg; /* no import on explicit () */
eb8433b7 3525 }
88d95a4d 3526 else if (SvNIOKp(((SVOP*)idop)->op_sv)) {
5f66b61c 3527 imop = NULL; /* use 5.0; */
468aa647
RGS		 3528 if (!aver)
3529 idop->op_private |= OPpCONST_NOVER;
b1cb66bf 3530 }
4633a7c4 3531 else {
0f79a09d
GS		 3532 SV *meth;
3533
eb8433b7
NC		 3534 if (PL_madskills)
3535 op_getmad(arg,pegop,'A');
3536
88d95a4d
JH		 3537 /* Make copy of idop so we don't free it twice */
3538 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
0f79a09d
GS		 3539
3540 /* Fake up a method call to import/unimport */
427d62a4 3541 meth = aver
18916d0d 3542 ? newSVpvs_share("import") : newSVpvs_share("unimport");
4633a7c4 3543 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
0f79a09d
GS		 3544 append_elem(OP_LIST,
3545 prepend_elem(OP_LIST, pack, list(arg)),
3546 newSVOP(OP_METHOD_NAMED, 0, meth)));
4633a7c4
LW		 3547 }
3548
a0d0e21e 3549 /* Fake up the BEGIN {}, which does its thing immediately. */
09bef843 3550 newATTRSUB(floor,
18916d0d 3551 newSVOP(OP_CONST, 0, newSVpvs_share("BEGIN")),
5f66b61c
AL		 3552 NULL,
3553 NULL,
a0d0e21e 3554 append_elem(OP_LINESEQ,
b1cb66bf 3555 append_elem(OP_LINESEQ,
bd61b366
SS		 3556 newSTATEOP(0, NULL, newUNOP(OP_REQUIRE, 0, idop)),
3557 newSTATEOP(0, NULL, veop)),
3558 newSTATEOP(0, NULL, imop) ));
85e6fe83 3559
70f5e4ed
JH		 3560 /* The "did you use incorrect case?" warning used to be here.
3561 * The problem is that on case-insensitive filesystems one
3562 * might get false positives for "use" (and "require"):
3563 * "use Strict" or "require CARP" will work. This causes
3564 * portability problems for the script: in case-strict
3565 * filesystems the script will stop working.
3566 *
3567 * The "incorrect case" warning checked whether "use Foo"
3568 * imported "Foo" to your namespace, but that is wrong, too:
3569 * there is no requirement nor promise in the language that
3570 * a Foo.pm should or would contain anything in package "Foo".
3571 *
3572 * There is very little Configure-wise that can be done, either:
3573 * the case-sensitivity of the build filesystem of Perl does not
3574 * help in guessing the case-sensitivity of the runtime environment.
3575 */
18fc9488 3576
c305c6a0 3577 PL_hints |= HINT_BLOCK_SCOPE;
3280af22
NIS		 3578 PL_copline = NOLINE;
3579 PL_expect = XSTATE;
8ec8fbef 3580 PL_cop_seqmax++; /* Purely for B::*'s benefit */
eb8433b7
NC		 3581
3582#ifdef PERL_MAD
3583 if (!PL_madskills) {
3584 /* FIXME - don't allocate pegop if !PL_madskills */
3585 op_free(pegop);
1d866c12 3586 return NULL;
eb8433b7
NC		 3587 }
3588 return pegop;
3589#endif
85e6fe83
LW		 3590}
3591
7d3fb230 3592/*
ccfc67b7
JH		 3593=head1 Embedding Functions
3594
7d3fb230
BS		 3595=for apidoc load_module
3596
3597Loads the module whose name is pointed to by the string part of name.
3598Note that the actual module name, not its filename, should be given.
3599Eg, "Foo::Bar" instead of "Foo/Bar.pm". flags can be any of
3600PERL_LOADMOD_DENY, PERL_LOADMOD_NOIMPORT, or PERL_LOADMOD_IMPORT_OPS
3601(or 0 for no flags). ver, if specified, provides version semantics
3602similar to C<use Foo::Bar VERSION>. The optional trailing SV*
3603arguments can be used to specify arguments to the module's import()
3604method, similar to C<use Foo::Bar VERSION LIST>.
3605
3606=cut */
3607
e4783991
GS		 3608void
3609Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
3610{
3611 va_list args;
3612 va_start(args, ver);
3613 vload_module(flags, name, ver, &args);
3614 va_end(args);
3615}
3616
3617#ifdef PERL_IMPLICIT_CONTEXT
3618void
3619Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
3620{
3621 dTHX;
3622 va_list args;
3623 va_start(args, ver);
3624 vload_module(flags, name, ver, &args);
3625 va_end(args);
3626}
3627#endif
3628
3629void
3630Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
3631{
97aff369 3632 dVAR;
551405c4 3633 OP *veop, *imop;
e4783991 3634
551405c4 3635 OP * const modname = newSVOP(OP_CONST, 0, name);
e4783991
GS		 3636 modname->op_private |= OPpCONST_BARE;
3637 if (ver) {
3638 veop = newSVOP(OP_CONST, 0, ver);
3639 }
3640 else
5f66b61c 3641 veop = NULL;
e4783991
GS		 3642 if (flags & PERL_LOADMOD_NOIMPORT) {
3643 imop = sawparens(newNULLLIST());
3644 }
3645 else if (flags & PERL_LOADMOD_IMPORT_OPS) {
3646 imop = va_arg(*args, OP*);
3647 }
3648 else {
3649 SV *sv;
5f66b61c 3650 imop = NULL;
e4783991
GS		 3651 sv = va_arg(*args, SV*);
3652 while (sv) {
3653 imop = append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
3654 sv = va_arg(*args, SV*);
3655 }
3656 }
81885997 3657 {
6867be6d
AL		 3658 const line_t ocopline = PL_copline;
3659 COP * const ocurcop = PL_curcop;
3660 const int oexpect = PL_expect;
81885997
GS		 3661
3662 utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
3663 veop, modname, imop);
3664 PL_expect = oexpect;
3665 PL_copline = ocopline;
834a3ffa 3666 PL_curcop = ocurcop;
81885997 3667 }
e4783991
GS		 3668}
3669
79072805 3670OP *
850e8516 3671Perl_dofile(pTHX_ OP *term, I32 force_builtin)
78ca652e 3672{
97aff369 3673 dVAR;
78ca652e 3674 OP *doop;
a0714e2c 3675 GV *gv = NULL;
78ca652e 3676
850e8516 3677 if (!force_builtin) {
fafc274c 3678 gv = gv_fetchpvs("do", GV_NOTQUAL, SVt_PVCV);
850e8516 3679 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
a4fc7abc 3680 GV * const * const gvp = (GV**)hv_fetchs(PL_globalstash, "do", FALSE);
a0714e2c 3681 gv = gvp ? *gvp : NULL;
850e8516
RGS		 3682 }
3683 }
78ca652e 3684
b9f751c0 3685 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
78ca652e
GS		 3686 doop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
3687 append_elem(OP_LIST, term,
3688 scalar(newUNOP(OP_RV2CV, 0,
d4c19fe8 3689 newGVOP(OP_GV, 0, gv))))));
78ca652e
GS		 3690 }
3691 else {
3692 doop = newUNOP(OP_DOFILE, 0, scalar(term));
3693 }
3694 return doop;
3695}
3696
3697OP *
864dbfa3 3698Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
79072805
LW		 3699{
3700 return newBINOP(OP_LSLICE, flags,
8990e307
LW		 3701 list(force_list(subscript)),
3702 list(force_list(listval)) );
79072805
LW		 3703}
3704
76e3520e 3705STATIC I32
504618e9 3706S_is_list_assignment(pTHX_ register const OP *o)
79072805 3707{
11343788 3708 if (!o)
79072805
LW		 3709 return TRUE;
3710
11343788
MB		 3711 if (o->op_type == OP_NULL && o->op_flags & OPf_KIDS)
3712 o = cUNOPo->op_first;
79072805 3713
11343788 3714 if (o->op_type == OP_COND_EXPR) {
504618e9
AL		 3715 const I32 t = is_list_assignment(cLOGOPo->op_first->op_sibling);
3716 const I32 f = is_list_assignment(cLOGOPo->op_first->op_sibling->op_sibling);
79072805
LW		 3717
3718 if (t && f)
3719 return TRUE;
3720 if (t || f)
3721 yyerror("Assignment to both a list and a scalar");
3722 return FALSE;
3723 }
3724
95f0a2f1
SB		 3725 if (o->op_type == OP_LIST &&
3726 (o->op_flags & OPf_WANT) == OPf_WANT_SCALAR &&
3727 o->op_private & OPpLVAL_INTRO)
3728 return FALSE;
3729
11343788
MB		 3730 if (o->op_type == OP_LIST || o->op_flags & OPf_PARENS ||
3731 o->op_type == OP_RV2AV || o->op_type == OP_RV2HV ||
3732 o->op_type == OP_ASLICE || o->op_type == OP_HSLICE)
79072805
LW		 3733 return TRUE;
3734
11343788 3735 if (o->op_type == OP_PADAV || o->op_type == OP_PADHV)
93a17b20
LW		 3736 return TRUE;
3737
11343788 3738 if (o->op_type == OP_RV2SV)
79072805
LW		 3739 return FALSE;
3740
3741 return FALSE;
3742}
3743
3744OP *
864dbfa3 3745Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
79072805 3746{
97aff369 3747 dVAR;
11343788 3748 OP *o;
79072805 3749
a0d0e21e 3750 if (optype) {
c963b151 3751 if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN || optype == OP_DORASSIGN) {
a0d0e21e
LW		 3752 return newLOGOP(optype, 0,
3753 mod(scalar(left), optype),
3754 newUNOP(OP_SASSIGN, 0, scalar(right)));
3755 }
3756 else {
3757 return newBINOP(optype, OPf_STACKED,
3758 mod(scalar(left), optype), scalar(right));
3759 }
3760 }
3761
504618e9 3762 if (is_list_assignment(left)) {
10c8fecd
GS		 3763 OP *curop;
3764
3280af22 3765 PL_modcount = 0;
dbfe47cf
RD		 3766 /* Grandfathering $[ assignment here. Bletch.*/
3767 /* Only simple assignments like C<< ($[) = 1 >> are allowed */
3768 PL_eval_start = (left->op_type == OP_CONST) ? right : 0;
463ee0b2 3769 left = mod(left, OP_AASSIGN);
3280af22
NIS		 3770 if (PL_eval_start)
3771 PL_eval_start = 0;
dbfe47cf 3772 else if (left->op_type == OP_CONST) {
eb8433b7 3773 /* FIXME for MAD */
dbfe47cf
RD		 3774 /* Result of assignment is always 1 (or we'd be dead already) */
3775 return newSVOP(OP_CONST, 0, newSViv(1));
a0d0e21e 3776 }
10c8fecd
GS		 3777 curop = list(force_list(left));
3778 o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop);
eb160463 3779 o->op_private = (U8)(0 | (flags >> 8));
dd2155a4
DM		 3780
3781 /* PL_generation sorcery:
3782 * an assignment like ($a,$b) = ($c,$d) is easier than
3783 * ($a,$b) = ($c,$a), since there is no need for temporary vars.
3784 * To detect whether there are common vars, the global var
3785 * PL_generation is incremented for each assign op we compile.
3786 * Then, while compiling the assign op, we run through all the
3787 * variables on both sides of the assignment, setting a spare slot
3788 * in each of them to PL_generation. If any of them already have
3789 * that value, we know we've got commonality. We could use a
3790 * single bit marker, but then we'd have to make 2 passes, first
3791 * to clear the flag, then to test and set it. To find somewhere
3792 * to store these values, evil chicanery is done with SvCUR().
3793 */
3794
a0d0e21e 3795 if (!(left->op_private & OPpLVAL_INTRO)) {
11343788 3796 OP *lastop = o;
3280af22 3797 PL_generation++;
11343788 3798 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
22c35a8c 3799 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
79072805 3800 if (curop->op_type == OP_GV) {
638eceb6 3801 GV *gv = cGVOPx_gv(curop);
169d2d72
NC		 3802 if (gv == PL_defgv
3803 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
79072805 3804 break;
169d2d72 3805 GvASSIGN_GENERATION_set(gv, PL_generation);
79072805 3806 }
748a9306
LW		 3807 else if (curop->op_type == OP_PADSV ||
3808 curop->op_type == OP_PADAV ||
3809 curop->op_type == OP_PADHV ||
dd2155a4
DM		 3810 curop->op_type == OP_PADANY)
3811 {
3812 if (PAD_COMPNAME_GEN(curop->op_targ)
92251a1e 3813 == (STRLEN)PL_generation)
748a9306 3814 break;
b162af07 3815 PAD_COMPNAME_GEN_set(curop->op_targ, PL_generation);
dd2155a4 3816
748a9306 3817 }
79072805
LW		 3818 else if (curop->op_type == OP_RV2CV)
3819 break;
3820 else if (curop->op_type == OP_RV2SV ||
3821 curop->op_type == OP_RV2AV ||
3822 curop->op_type == OP_RV2HV ||
3823 curop->op_type == OP_RV2GV) {
3824 if (lastop->op_type != OP_GV) /* funny deref? */
3825 break;
3826 }
1167e5da
SM		 3827 else if (curop->op_type == OP_PUSHRE) {
3828 if (((PMOP*)curop)->op_pmreplroot) {
b3f5893f 3829#ifdef USE_ITHREADS
dd2155a4
DM		 3830 GV *gv = (GV*)PAD_SVl(INT2PTR(PADOFFSET,
3831 ((PMOP*)curop)->op_pmreplroot));
b3f5893f 3832#else
1167e5da 3833 GV *gv = (GV*)((PMOP*)curop)->op_pmreplroot;
b3f5893f 3834#endif
169d2d72
NC		 3835 if (gv == PL_defgv
3836 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
1167e5da 3837 break;
169d2d72
NC		 3838 GvASSIGN_GENERATION_set(gv, PL_generation);
3839 GvASSIGN_GENERATION_set(gv, PL_generation);
b2ffa427 3840 }
1167e5da 3841 }
79072805
LW		 3842 else
3843 break;
3844 }
3845 lastop = curop;
3846 }
11343788 3847 if (curop != o)
10c8fecd 3848 o->op_private |= OPpASSIGN_COMMON;
79072805 3849 }
c07a80fd 3850 if (right && right->op_type == OP_SPLIT) {
3851 OP* tmpop;
3852 if ((tmpop = ((LISTOP*)right)->op_first) &&
3853 tmpop->op_type == OP_PUSHRE)
3854 {
551405c4 3855 PMOP * const pm = (PMOP*)tmpop;
c07a80fd 3856 if (left->op_type == OP_RV2AV &&
3857 !(left->op_private & OPpLVAL_INTRO) &&
11343788 3858 !(o->op_private & OPpASSIGN_COMMON) )
c07a80fd 3859 {
3860 tmpop = ((UNOP*)left)->op_first;
3861 if (tmpop->op_type == OP_GV && !pm->op_pmreplroot) {
971a9dd3 3862#ifdef USE_ITHREADS
ba89bb6e 3863 pm->op_pmreplroot = INT2PTR(OP*, cPADOPx(tmpop)->op_padix);
971a9dd3
GS		 3864 cPADOPx(tmpop)->op_padix = 0; /* steal it */
3865#else
3866 pm->op_pmreplroot = (OP*)cSVOPx(tmpop)->op_sv;
a0714e2c 3867 cSVOPx(tmpop)->op_sv = NULL; /* steal it */
971a9dd3 3868#endif
c07a80fd 3869 pm->op_pmflags |= PMf_ONCE;
11343788 3870 tmpop = cUNOPo->op_first; /* to list (nulled) */
c07a80fd 3871 tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
5f66b61c 3872 tmpop->op_sibling = NULL; /* don't free split */
c07a80fd 3873 right->op_next = tmpop->op_next; /* fix starting loc */
eb8433b7
NC		 3874#ifdef PERL_MAD
3875 op_getmad(o,right,'R'); /* blow off assign */
3876#else
11343788 3877 op_free(o); /* blow off assign */
eb8433b7 3878#endif
54310121 3879 right->op_flags &= ~OPf_WANT;
a5f75d66 3880 /* "I don't know and I don't care." */
c07a80fd 3881 return right;
3882 }
3883 }
3884 else {
e6438c1a 3885 if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
c07a80fd 3886 ((LISTOP*)right)->op_last->op_type == OP_CONST)
3887 {
3888 SV *sv = ((SVOP*)((LISTOP*)right)->op_last)->op_sv;
3889 if (SvIVX(sv) == 0)
3280af22 3890 sv_setiv(sv, PL_modcount+1);
c07a80fd 3891 }
3892 }
3893 }
3894 }
11343788 3895 return o;
79072805
LW		 3896 }
3897 if (!right)
3898 right = newOP(OP_UNDEF, 0);
3899 if (right->op_type == OP_READLINE) {
3900 right->op_flags |= OPf_STACKED;
463ee0b2 3901 return newBINOP(OP_NULL, flags, mod(scalar(left), OP_SASSIGN), scalar(right));
79072805 3902 }
a0d0e21e 3903 else {
3280af22 3904 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
11343788 3905 o = newBINOP(OP_SASSIGN, flags,
463ee0b2 3906 scalar(right), mod(scalar(left), OP_SASSIGN) );
3280af22
NIS		 3907 if (PL_eval_start)
3908 PL_eval_start = 0;
748a9306 3909 else {
eb8433b7 3910 /* FIXME for MAD */
3b6547f5 3911 op_free(o);
fc15ae8f 3912 o = newSVOP(OP_CONST, 0, newSViv(CopARYBASE_get(&PL_compiling)));
2e0ae2d3 3913 o->op_private |= OPpCONST_ARYBASE;
a0d0e21e
LW		 3914 }
3915 }
11343788 3916 return o;
79072805
LW		 3917}
3918
3919OP *
864dbfa3 3920Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
79072805 3921{
27da23d5 3922 dVAR;
e1ec3a88 3923 const U32 seq = intro_my();
79072805
LW		 3924 register COP *cop;
3925
b7dc083c 3926 NewOp(1101, cop, 1, COP);
57843af0 3927 if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
8990e307 3928 cop->op_type = OP_DBSTATE;
22c35a8c 3929 cop->op_ppaddr = PL_ppaddr[ OP_DBSTATE ];
8990e307
LW		 3930 }
3931 else {
3932 cop->op_type = OP_NEXTSTATE;
22c35a8c 3933 cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ];
8990e307 3934 }
eb160463 3935 cop->op_flags = (U8)flags;
623e6609 3936 CopHINTS_set(cop, PL_hints);
ff0cee69 3937#ifdef NATIVE_HINTS
3938 cop->op_private |= NATIVE_HINTS;
3939#endif
623e6609 3940 CopHINTS_set(&PL_compiling, CopHINTS_get(cop));
79072805
LW		 3941 cop->op_next = (OP*)cop;
3942
463ee0b2
LW		 3943 if (label) {
3944 cop->cop_label = label;
3280af22 3945 PL_hints |= HINT_BLOCK_SCOPE;
463ee0b2 3946 }
bbce6d69 3947 cop->cop_seq = seq;
fc15ae8f 3948 CopARYBASE_set(cop, CopARYBASE_get(PL_curcop));
0453d815 3949 if (specialWARN(PL_curcop->cop_warnings))
599cee73 3950 cop->cop_warnings = PL_curcop->cop_warnings ;
1c846c1f 3951 else
599cee73 3952 cop->cop_warnings = newSVsv(PL_curcop->cop_warnings) ;
ac27b0f5
NIS		 3953 if (specialCopIO(PL_curcop->cop_io))
3954 cop->cop_io = PL_curcop->cop_io;
3955 else
3956 cop->cop_io = newSVsv(PL_curcop->cop_io) ;
b3ca2e83
NC		 3957 cop->cop_hints = PL_curcop->cop_hints;
3958 if (cop->cop_hints) {
cbb1fbea 3959 HINTS_REFCNT_LOCK;
b3ca2e83 3960 cop->cop_hints->refcounted_he_refcnt++;
cbb1fbea 3961 HINTS_REFCNT_UNLOCK;
b3ca2e83 3962 }
79072805 3963
3280af22 3964 if (PL_copline == NOLINE)
57843af0 3965 CopLINE_set(cop, CopLINE(PL_curcop));
79072805 3966 else {
57843af0 3967 CopLINE_set(cop, PL_copline);
3280af22 3968 PL_copline = NOLINE;
79072805 3969 }
57843af0 3970#ifdef USE_ITHREADS
f4dd75d9 3971 CopFILE_set(cop, CopFILE(PL_curcop)); /* XXX share in a pvtable? */
57843af0 3972#else
f4dd75d9 3973 CopFILEGV_set(cop, CopFILEGV(PL_curcop));
57843af0 3974#endif
11faa288 3975 CopSTASH_set(cop, PL_curstash);
79072805 3976
3280af22 3977 if (PERLDB_LINE && PL_curstash != PL_debstash) {
fe8247eb 3978 SV * const * const svp = av_fetch(CopFILEAVx(PL_curcop), (I32)CopLINE(cop), FALSE);
2d03de9c
AL		 3979 if (svp && *svp != &PL_sv_undef ) {
3980 (void)SvIOK_on(*svp);
45977657 3981 SvIV_set(*svp, PTR2IV(cop));
1eb1540c 3982 }
93a17b20
LW		 3983 }
3984
722969e2 3985 return prepend_elem(OP_LINESEQ, (OP*)cop, o);
79072805
LW		 3986}
3987
bbce6d69 3988
79072805 3989OP *
864dbfa3 3990Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
79072805 3991{
27da23d5 3992 dVAR;
883ffac3
CS		 3993 return new_logop(type, flags, &first, &other);
3994}
3995
3bd495df 3996STATIC OP *
cea2e8a9 3997S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
883ffac3 3998{
27da23d5 3999 dVAR;
79072805 4000 LOGOP *logop;
11343788 4001 OP *o;
883ffac3 4002 OP *first = *firstp;
b22e6366 4003 OP * const other = *otherp;
79072805 4004
a0d0e21e
LW		 4005 if (type == OP_XOR) /* Not short circuit, but here by precedence. */
4006 return newBINOP(type, flags, scalar(first), scalar(other));
4007
8990e307 4008 scalarboolean(first);
79072805 4009 /* optimize "!a && b" to "a || b", and "!a || b" to "a && b" */
68726e16
NC		 4010 if (first->op_type == OP_NOT
4011 && (first->op_flags & OPf_SPECIAL)
4012 && (first->op_flags & OPf_KIDS)) {
79072805
LW		 4013 if (type == OP_AND || type == OP_OR) {
4014 if (type == OP_AND)
4015 type = OP_OR;
4016 else
4017 type = OP_AND;
11343788 4018 o = first;
883ffac3 4019 first = *firstp = cUNOPo->op_first;
11343788
MB		 4020 if (o->op_next)
4021 first->op_next = o->op_next;
5f66b61c 4022 cUNOPo->op_first = NULL;
eb8433b7
NC		 4023#ifdef PERL_MAD
4024 op_getmad(o,first,'O');
4025#else
11343788 4026 op_free(o);
eb8433b7 4027#endif
79072805
LW		 4028 }
4029 }
4030 if (first->op_type == OP_CONST) {
39a440a3
DM		 4031 if (first->op_private & OPpCONST_STRICT)
4032 no_bareword_allowed(first);
041457d9 4033 else if ((first->op_private & OPpCONST_BARE) && ckWARN(WARN_BAREWORD))
989dfb19 4034 Perl_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional");
75cc09e4
MHM		 4035 if ((type == OP_AND && SvTRUE(((SVOP*)first)->op_sv)) ||
4036 (type == OP_OR && !SvTRUE(((SVOP*)first)->op_sv)) ||
4037 (type == OP_DOR && !SvOK(((SVOP*)first)->op_sv))) {
5f66b61c 4038 *firstp = NULL;
d6fee5c7
DM		 4039 if (other->op_type == OP_CONST)
4040 other->op_private |= OPpCONST_SHORTCIRCUIT;
eb8433b7
NC		 4041 if (PL_madskills) {
4042 OP *newop = newUNOP(OP_NULL, 0, other);
4043 op_getmad(first, newop, '1');
4044 newop->op_targ = type; /* set "was" field */
4045 return newop;
4046 }
4047 op_free(first);
79072805
LW		 4048 return other;
4049 }
4050 else {
7921d0f2 4051 /* check for C<my $x if 0>, or C<my($x,$y) if 0> */
6867be6d 4052 const OP *o2 = other;
7921d0f2
DM		 4053 if ( ! (o2->op_type == OP_LIST
4054 && (( o2 = cUNOPx(o2)->op_first))
4055 && o2->op_type == OP_PUSHMARK
4056 && (( o2 = o2->op_sibling)) )
4057 )
4058 o2 = other;
4059 if ((o2->op_type == OP_PADSV || o2->op_type == OP_PADAV
4060 || o2->op_type == OP_PADHV)
4061 && o2->op_private & OPpLVAL_INTRO
4062 && ckWARN(WARN_DEPRECATED))
4063 {
4064 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
4065 "Deprecated use of my() in false conditional");
4066 }
4067
5f66b61c 4068 *otherp = NULL;
d6fee5c7
DM		 4069 if (first->op_type == OP_CONST)
4070 first->op_private |= OPpCONST_SHORTCIRCUIT;
eb8433b7
NC		 4071 if (PL_madskills) {
4072 first = newUNOP(OP_NULL, 0, first);
4073 op_getmad(other, first, '2');
4074 first->op_targ = type; /* set "was" field */
4075 }
4076 else
4077 op_free(other);
79072805
LW		 4078 return first;
4079 }
4080 }
041457d9
DM		 4081 else if ((first->op_flags & OPf_KIDS) && type != OP_DOR
4082 && ckWARN(WARN_MISC)) /* [#24076] Don't warn for <FH> err FOO. */
59e10468 4083 {
b22e6366
AL		 4084 const OP * const k1 = ((UNOP*)first)->op_first;
4085 const OP * const k2 = k1->op_sibling;
a6006777 4086 OPCODE warnop = 0;
4087 switch (first->op_type)
4088 {
4089 case OP_NULL:
4090 if (k2 && k2->op_type == OP_READLINE
4091 && (k2->op_flags & OPf_STACKED)
1c846c1f 4092 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
72b16652 4093 {
a6006777 4094 warnop = k2->op_type;
72b16652 4095 }
a6006777 4096 break;
4097
4098 case OP_SASSIGN:
68dc0745 4099 if (k1->op_type == OP_READDIR
4100 || k1->op_type == OP_GLOB
72b16652 4101 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
68dc0745 4102 || k1->op_type == OP_EACH)
72b16652
GS		 4103 {
4104 warnop = ((k1->op_type == OP_NULL)
eb160463 4105 ? (OPCODE)k1->op_targ : k1->op_type);
72b16652 4106 }
a6006777 4107 break;
4108 }
8ebc5c01 4109 if (warnop) {
6867be6d 4110 const line_t oldline = CopLINE(PL_curcop);
57843af0 4111 CopLINE_set(PL_curcop, PL_copline);
9014280d 4112 Perl_warner(aTHX_ packWARN(WARN_MISC),
599cee73 4113 "Value of %s%s can be \"0\"; test with defined()",
22c35a8c 4114 PL_op_desc[warnop],
68dc0745 4115 ((warnop == OP_READLINE || warnop == OP_GLOB)
4116 ? " construct" : "() operator"));
57843af0 4117 CopLINE_set(PL_curcop, oldline);
8ebc5c01 4118 }
a6006777 4119 }
79072805
LW		 4120
4121 if (!other)
4122 return first;
4123
c963b151 4124 if (type == OP_ANDASSIGN || type == OP_ORASSIGN || type == OP_DORASSIGN)
a0d0e21e
LW		 4125 other->op_private |= OPpASSIGN_BACKWARDS; /* other is an OP_SASSIGN */
4126
b7dc083c 4127 NewOp(1101, logop, 1, LOGOP);
79072805 4128
eb160463 4129 logop->op_type = (OPCODE)type;
22c35a8c 4130 logop->op_ppaddr = PL_ppaddr[type];
79072805 4131 logop->op_first = first;
585ec06d 4132 logop->op_flags = (U8)(flags | OPf_KIDS);
79072805 4133 logop->op_other = LINKLIST(other);
eb160463 4134 logop->op_private = (U8)(1 | (flags >> 8));
79072805
LW		 4135
4136 /* establish postfix order */
4137 logop->op_next = LINKLIST(first);
4138 first->op_next = (OP*)logop;
4139 first->op_sibling = other;
4140
463d09e6
RGS		 4141 CHECKOP(type,logop);
4142
11343788
MB		 4143 o = newUNOP(OP_NULL, 0, (OP*)logop);
4144 other->op_next = o;
79072805 4145
11343788 4146 return o;
79072805
LW		 4147}
4148
4149OP *
864dbfa3 4150Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
79072805 4151{
27da23d5 4152 dVAR;
1a67a97c
SM		 4153 LOGOP *logop;
4154 OP *start;
11343788 4155 OP *o;
79072805 4156
b1cb66bf 4157 if (!falseop)
4158 return newLOGOP(OP_AND, 0, first, trueop);
4159 if (!trueop)
4160 return newLOGOP(OP_OR, 0, first, falseop);
79072805 4161
8990e307 4162 scalarboolean(first);
79072805 4163 if (first->op_type == OP_CONST) {
2bc6235c 4164 if (first->op_private & OPpCONST_BARE &&
b22e6366
AL		 4165 first->op_private & OPpCONST_STRICT) {
4166 no_bareword_allowed(first);
4167 }
79072805 4168 if (SvTRUE(((SVOP*)first)->op_sv)) {
eb8433b7
NC		 4169#ifdef PERL_MAD
4170 if (PL_madskills) {
4171 trueop = newUNOP(OP_NULL, 0, trueop);
4172 op_getmad(first,trueop,'C');
4173 op_getmad(falseop,trueop,'e');
4174 }
4175 /* FIXME for MAD - should there be an ELSE here? */
4176#else
79072805 4177 op_free(first);
b1cb66bf 4178 op_free(falseop);
eb8433b7 4179#endif
b1cb66bf 4180 return trueop;
79072805
LW		 4181 }
4182 else {
eb8433b7
NC		 4183#ifdef PERL_MAD
4184 if (PL_madskills) {
4185 falseop = newUNOP(OP_NULL, 0, falseop);
4186 op_getmad(first,falseop,'C');
4187 op_getmad(trueop,falseop,'t');
4188 }
4189 /* FIXME for MAD - should there be an ELSE here? */
4190#else
79072805 4191 op_free(first);
b1cb66bf 4192 op_free(trueop);
eb8433b7 4193#endif
b1cb66bf 4194 return falseop;
79072805
LW		 4195 }
4196 }
1a67a97c
SM		 4197 NewOp(1101, logop, 1, LOGOP);
4198 logop->op_type = OP_COND_EXPR;
4199 logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR];
4200 logop->op_first = first;
585ec06d 4201 logop->op_flags = (U8)(flags | OPf_KIDS);
eb160463 4202 logop->op_private = (U8)(1 | (flags >> 8));
1a67a97c
SM		 4203 logop->op_other = LINKLIST(trueop);
4204 logop->op_next = LINKLIST(falseop);
79072805 4205
463d09e6
RGS		 4206 CHECKOP(OP_COND_EXPR, /* that's logop->op_type */
4207 logop);
79072805
LW		 4208
4209 /* establish postfix order */
1a67a97c
SM		 4210 start = LINKLIST(first);
4211 first->op_next = (OP*)logop;
79072805 4212
b1cb66bf 4213 first->op_sibling = trueop;
4214 trueop->op_sibling = falseop;
1a67a97c 4215 o = newUNOP(OP_NULL, 0, (OP*)logop);
79072805 4216
1a67a97c 4217 trueop->op_next = falseop->op_next = o;
79072805 4218
1a67a97c 4219 o->op_next = start;
11343788 4220 return o;
79072805
LW		 4221}
4222
4223OP *
864dbfa3 4224Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
79072805 4225{
27da23d5 4226 dVAR;
1a67a97c 4227 LOGOP *range;
79072805
LW		 4228 OP *flip;
4229 OP *flop;
1a67a97c 4230 OP *leftstart;
11343788 4231 OP *o;
79072805 4232
1a67a97c 4233 NewOp(1101, range, 1, LOGOP);
79072805 4234
1a67a97c
SM		 4235 range->op_type = OP_RANGE;
4236 range->op_ppaddr = PL_ppaddr[OP_RANGE];
4237 range->op_first = left;
4238 range->op_flags = OPf_KIDS;
4239 leftstart = LINKLIST(left);
4240 range->op_other = LINKLIST(right);
eb160463 4241 range->op_private = (U8)(1 | (flags >> 8));
79072805
LW		 4242
4243 left->op_sibling = right;
4244
1a67a97c
SM		 4245 range->op_next = (OP*)range;
4246 flip = newUNOP(OP_FLIP, flags, (OP*)range);
79072805 4247 flop = newUNOP(OP_FLOP, 0, flip);
11343788 4248 o = newUNOP(OP_NULL, 0, flop);
79072805 4249 linklist(flop);
1a67a97c 4250 range->op_next = leftstart;
79072805
LW		 4251
4252 left->op_next = flip;
4253 right->op_next = flop;
4254
1a67a97c
SM		 4255 range->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
4256 sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
ed6116ce 4257 flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
79072805
LW		 4258 sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
4259
4260 flip->op_private = left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
4261 flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
4262
11343788 4263 flip->op_next = o;
79072805 4264 if (!flip->op_private || !flop->op_private)
11343788 4265 linklist(o); /* blow off optimizer unless constant */
79072805 4266
11343788 4267 return o;
79072805
LW		 4268}
4269
4270OP *
864dbfa3 4271Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
79072805 4272{
97aff369 4273 dVAR;
463ee0b2 4274 OP* listop;
11343788 4275 OP* o;
73d840c0 4276 const bool once = block && block->op_flags & OPf_SPECIAL &&
a0d0e21e 4277 (block->op_type == OP_ENTERSUB || block->op_type == OP_NULL);
46c461b5
AL		 4278
4279 PERL_UNUSED_ARG(debuggable);
93a17b20 4280
463ee0b2
LW		 4281 if (expr) {
4282 if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
4283 return block; /* do {} while 0 does once */
fb73857a 4284 if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
4285 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
774d564b 4286 expr = newUNOP(OP_DEFINED, 0,
54b9620d 4287 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
55d729e4 4288 } else if (expr->op_flags & OPf_KIDS) {
46c461b5
AL		 4289 const OP * const k1 = ((UNOP*)expr)->op_first;
4290 const OP * const k2 = k1 ? k1->op_sibling : NULL;
55d729e4 4291 switch (expr->op_type) {
1c846c1f 4292 case OP_NULL:
55d729e4
GS		 4293 if (k2 && k2->op_type == OP_READLINE
4294 && (k2->op_flags & OPf_STACKED)
1c846c1f 4295 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
55d729e4 4296 expr = newUNOP(OP_DEFINED, 0, expr);
1c846c1f 4297 break;
55d729e4
GS		 4298
4299 case OP_SASSIGN:
06dc7ac6 4300 if (k1 && (k1->op_type == OP_READDIR
55d729e4 4301 || k1->op_type == OP_GLOB
6531c3e6 4302 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
06dc7ac6 4303 || k1->op_type == OP_EACH))
55d729e4
GS		 4304 expr = newUNOP(OP_DEFINED, 0, expr);
4305 break;
4306 }
774d564b 4307 }
463ee0b2 4308 }
93a17b20 4309
e1548254
RGS		 4310 /* if block is null, the next append_elem() would put UNSTACK, a scalar
4311 * op, in listop. This is wrong. [perl #27024] */
4312 if (!block)
4313 block = newOP(OP_NULL, 0);
8990e307 4314 listop = append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
883ffac3 4315 o = new_logop(OP_AND, 0, &expr, &listop);
463ee0b2 4316
883ffac3
CS		 4317 if (listop)
4318 ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
79072805 4319
11343788
MB		 4320 if (once && o != listop)
4321 o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
79072805 4322
11343788
MB		 4323 if (o == listop)
4324 o = newUNOP(OP_NULL, 0, o); /* or do {} while 1 loses outer block */
748a9306 4325
11343788
MB		 4326 o->op_flags |= flags;
4327 o = scope(o);
4328 o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
4329 return o;
79072805
LW		 4330}
4331
4332OP *
a034e688
DM		 4333Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32
4334whileline, OP *expr, OP *block, OP *cont, I32 has_my)
79072805 4335{
27da23d5 4336 dVAR;
79072805 4337 OP *redo;
c445ea15 4338 OP *next = NULL;
79072805 4339 OP *listop;
11343788 4340 OP *o;
1ba6ee2b 4341 U8 loopflags = 0;
46c461b5
AL		 4342
4343 PERL_UNUSED_ARG(debuggable);
79072805 4344
2d03de9c
AL		 4345 if (expr) {
4346 if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
4347 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
4348 expr = newUNOP(OP_DEFINED, 0,
4349 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
4350 } else if (expr->op_flags & OPf_KIDS) {
4351 const OP * const k1 = ((UNOP*)expr)->op_first;
4352 const OP * const k2 = (k1) ? k1->op_sibling : NULL;
4353 switch (expr->op_type) {
4354 case OP_NULL:
4355 if (k2 && k2->op_type == OP_READLINE
4356 && (k2->op_flags & OPf_STACKED)
4357 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
4358 expr = newUNOP(OP_DEFINED, 0, expr);
4359 break;
55d729e4 4360
2d03de9c 4361 case OP_SASSIGN:
72c8de1a 4362 if (k1 && (k1->op_type == OP_READDIR
2d03de9c
AL		 4363 || k1->op_type == OP_GLOB
4364 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
72c8de1a 4365 || k1->op_type == OP_EACH))
2d03de9c
AL		 4366 expr = newUNOP(OP_DEFINED, 0, expr);
4367 break;
4368 }
55d729e4 4369 }
748a9306 4370 }
79072805
LW		 4371
4372 if (!block)
4373 block = newOP(OP_NULL, 0);
a034e688 4374 else if (cont || has_my) {
87246558
GS		 4375 block = scope(block);
4376 }
79072805 4377
1ba6ee2b 4378 if (cont) {
79072805 4379 next = LINKLIST(cont);
1ba6ee2b 4380 }
fb73857a 4381 if (expr) {
551405c4 4382 OP * const unstack = newOP(OP_UNSTACK, 0);
85538317
GS		 4383 if (!next)
4384 next = unstack;
4385 cont = append_elem(OP_LINESEQ, cont, unstack);
fb73857a 4386 }
79072805 4387
463ee0b2 4388 listop = append_list(OP_LINESEQ, (LISTOP*)block, (LISTOP*)cont);
79072805
LW		 4389 redo = LINKLIST(listop);
4390
4391 if (expr) {
eb160463 4392 PL_copline = (line_t)whileline;
883ffac3
CS		 4393 scalar(listop);
4394 o = new_logop(OP_AND, 0, &expr, &listop);
11343788 4395 if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
85e6fe83 4396 op_free(expr); /* oops, it's a while (0) */
463ee0b2 4397 op_free((OP*)loop);
5f66b61c 4398 return NULL; /* listop already freed by new_logop */
463ee0b2 4399 }
883ffac3 4400 if (listop)
497b47a8 4401 ((LISTOP*)listop)->op_last->op_next =
883ffac3 4402 (o == listop ? redo : LINKLIST(o));
79072805
LW		 4403 }
4404 else
11343788 4405 o = listop;
79072805
LW		 4406
4407 if (!loop) {
b7dc083c 4408 NewOp(1101,loop,1,LOOP);
79072805 4409 loop->op_type = OP_ENTERLOOP;
22c35a8c 4410 loop->op_ppaddr = PL_ppaddr[OP_ENTERLOOP];
79072805
LW		 4411 loop->op_private = 0;
4412 loop->op_next = (OP*)loop;
4413 }
4414
11343788 4415 o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
79072805
LW		 4416
4417 loop->op_redoop = redo;
11343788 4418 loop->op_lastop = o;
1ba6ee2b 4419 o->op_private |= loopflags;
79072805
LW		 4420
4421 if (next)
4422 loop->op_nextop = next;
4423 else
11343788 4424 loop->op_nextop = o;
79072805 4425
11343788
MB		 4426 o->op_flags |= flags;
4427 o->op_private |= (flags >> 8);
4428 return o;
79072805
LW		 4429}
4430
4431OP *
66a1b24b 4432Perl_newFOROP(pTHX_ I32 flags, char *label, line_t forline, OP *sv, OP *expr, OP *block, OP *cont)
79072805 4433{
27da23d5 4434 dVAR;
79072805 4435 LOOP *loop;
fb73857a 4436 OP *wop;
4bbc6d12 4437 PADOFFSET padoff = 0;
4633a7c4 4438 I32 iterflags = 0;
241416b8 4439 I32 iterpflags = 0;
d4c19fe8 4440 OP *madsv = NULL;
79072805 4441
79072805 4442 if (sv) {
85e6fe83 4443 if (sv->op_type == OP_RV2SV) { /* symbol table variable */
241416b8 4444 iterpflags = sv->op_private & OPpOUR_INTRO; /* for our $x () */
748a9306 4445 sv->op_type = OP_RV2GV;
22c35a8c 4446 sv->op_ppaddr = PL_ppaddr[OP_RV2GV];
0d863452
RH		 4447 if (cGVOPx_gv(cUNOPx(sv)->op_first) == PL_defgv)
4448 iterpflags |= OPpITER_DEF;
79072805 4449 }
85e6fe83 4450 else if (sv->op_type == OP_PADSV) { /* private variable */
241416b8 4451 iterpflags = sv->op_private & OPpLVAL_INTRO; /* for my $x () */
85e6fe83 4452 padoff = sv->op_targ;
eb8433b7
NC		 4453 if (PL_madskills)
4454 madsv = sv;
4455 else {
4456 sv->op_targ = 0;
4457 op_free(sv);
4458 }
5f66b61c 4459 sv = NULL;
85e6fe83 4460 }
54b9620d
MB		 4461 else if (sv->op_type == OP_THREADSV) { /* per-thread variable */
4462 padoff = sv->op_targ;
eb8433b7
NC		 4463 if (PL_madskills)
4464 madsv = sv;
4465 else {
4466 sv->op_targ = 0;
4467 iterflags |= OPf_SPECIAL;
4468 op_free(sv);
4469 }
5f66b61c 4470 sv = NULL;
54b9620d 4471 }
79072805 4472 else
cea2e8a9 4473 Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
0d863452
RH		 4474 if (padoff && strEQ(PAD_COMPNAME_PV(padoff), "$_"))
4475 iterpflags |= OPpITER_DEF;
79072805
LW		 4476 }
4477 else {
73d840c0 4478 const I32 offset = pad_findmy("$_");
00b1698f 4479 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
aabe9514
RGS		 4480 sv = newGVOP(OP_GV, 0, PL_defgv);
4481 }
4482 else {
4483 padoff = offset;
aabe9514 4484 }
0d863452 4485 iterpflags |= OPpITER_DEF;
79072805 4486 }
5f05dabc 4487 if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
89ea2908 4488 expr = mod(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART);
4633a7c4
LW		 4489 iterflags |= OPf_STACKED;
4490 }
89ea2908
GA		 4491 else if (expr->op_type == OP_NULL &&
4492 (expr->op_flags & OPf_KIDS) &&
4493 ((BINOP*)expr)->op_first->op_type == OP_FLOP)
4494 {
4495 /* Basically turn for($x..$y) into the same as for($x,$y), but we
4496 * set the STACKED flag to indicate that these values are to be
4497 * treated as min/max values by 'pp_iterinit'.
4498 */
d4c19fe8 4499 const UNOP* const flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
551405c4 4500 LOGOP* const range = (LOGOP*) flip->op_first;
66a1b24b
AL		 4501 OP* const left = range->op_first;
4502 OP* const right = left->op_sibling;
5152d7c7 4503 LISTOP* listop;
89ea2908
GA		 4504
4505 range->op_flags &= ~OPf_KIDS;
5f66b61c 4506 range->op_first = NULL;
89ea2908 4507
5152d7c7 4508 listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
1a67a97c
SM		 4509 listop->op_first->op_next = range->op_next;
4510 left->op_next = range->op_other;
5152d7c7
GS		 4511 right->op_next = (OP*)listop;
4512 listop->op_next = listop->op_first;
89ea2908 4513
eb8433b7
NC		 4514#ifdef PERL_MAD
4515 op_getmad(expr,(OP*)listop,'O');
4516#else
89ea2908 4517 op_free(expr);
eb8433b7 4518#endif
5152d7c7 4519 expr = (OP*)(listop);
93c66552 4520 op_null(expr);
89ea2908
GA		 4521 iterflags |= OPf_STACKED;
4522 }
4523 else {
4524 expr = mod(force_list(expr), OP_GREPSTART);
4525 }
4526
4633a7c4 4527 loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
89ea2908 4528 append_elem(OP_LIST, expr, scalar(sv))));
85e6fe83 4529 assert(!loop->op_next);
241416b8 4530 /* for my $x () sets OPpLVAL_INTRO;
14f338dc 4531 * for our $x () sets OPpOUR_INTRO */
c5661c80 4532 loop->op_private = (U8)iterpflags;
b7dc083c 4533#ifdef PL_OP_SLAB_ALLOC
155aba94
GS		 4534 {
4535 LOOP *tmp;
4536 NewOp(1234,tmp,1,LOOP);
bd5f3bc4 4537 Copy(loop,tmp,1,LISTOP);
238a4c30 4538 FreeOp(loop);
155aba94
GS		 4539 loop = tmp;
4540 }
b7dc083c 4541#else
85e6fe83 4542 Renew(loop, 1, LOOP);
1c846c1f 4543#endif
85e6fe83 4544 loop->op_targ = padoff;
a034e688 4545 wop = newWHILEOP(flags, 1, loop, forline, newOP(OP_ITER, 0), block, cont, 0);
eb8433b7
NC		 4546 if (madsv)
4547 op_getmad(madsv, (OP*)loop, 'v');
3280af22 4548 PL_copline = forline;
fb73857a 4549 return newSTATEOP(0, label, wop);
79072805
LW		 4550}
4551
8990e307 4552OP*
864dbfa3 4553Perl_newLOOPEX(pTHX_ I32 type, OP *label)
8990e307 4554{
97aff369 4555 dVAR;
11343788 4556 OP *o;
2d8e6c8d 4557
8990e307 4558 if (type != OP_GOTO || label->op_type == OP_CONST) {
cdaebead
MB		 4559 /* "last()" means "last" */
4560 if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS))
4561 o = newOP(type, OPf_SPECIAL);
4562 else {
4563 o = newPVOP(type, 0, savepv(label->op_type == OP_CONST
8b6b16e7 4564 ? SvPVx_nolen_const(((SVOP*)label)->op_sv)
cdaebead
MB		 4565 : ""));
4566 }
eb8433b7
NC		 4567#ifdef PERL_MAD
4568 op_getmad(label,o,'L');
4569#else
8990e307 4570 op_free(label);
eb8433b7 4571#endif
8990e307
LW		 4572 }
4573 else {
e3aba57a
RGS		 4574 /* Check whether it's going to be a goto &function */
4575 if (label->op_type == OP_ENTERSUB
4576 && !(label->op_flags & OPf_STACKED))
a0d0e21e 4577 label = newUNOP(OP_REFGEN, 0, mod(label, OP_REFGEN));
11343788 4578 o = newUNOP(type, OPf_STACKED, label);
8990e307 4579 }
3280af22 4580 PL_hints |= HINT_BLOCK_SCOPE;
11343788 4581 return o;
8990e307
LW		 4582}
4583
0d863452
RH		 4584/* if the condition is a literal array or hash
4585 (or @{ ... } etc), make a reference to it.
4586 */
4587STATIC OP *
4588S_ref_array_or_hash(pTHX_ OP *cond)
4589{
4590 if (cond
4591 && (cond->op_type == OP_RV2AV
4592 || cond->op_type == OP_PADAV
4593 || cond->op_type == OP_RV2HV
4594 || cond->op_type == OP_PADHV))
4595
4596 return newUNOP(OP_REFGEN,
4597 0, mod(cond, OP_REFGEN));
4598
4599 else
4600 return cond;
4601}
4602
4603/* These construct the optree fragments representing given()
4604 and when() blocks.
4605
4606 entergiven and enterwhen are LOGOPs; the op_other pointer
4607 points up to the associated leave op. We need this so we
4608 can put it in the context and make break/continue work.
4609 (Also, of course, pp_enterwhen will jump straight to
4610 op_other if the match fails.)
4611 */
4612
4613STATIC
4614OP *
4615S_newGIVWHENOP(pTHX_ OP *cond, OP *block,
4616 I32 enter_opcode, I32 leave_opcode,
4617 PADOFFSET entertarg)
4618{
97aff369 4619 dVAR;
0d863452
RH		 4620 LOGOP *enterop;
4621 OP *o;
4622
4623 NewOp(1101, enterop, 1, LOGOP);
4624 enterop->op_type = enter_opcode;
4625 enterop->op_ppaddr = PL_ppaddr[enter_opcode];
4626 enterop->op_flags = (U8) OPf_KIDS;
4627 enterop->op_targ = ((entertarg == NOT_IN_PAD) ? 0 : entertarg);
4628 enterop->op_private = 0;
4629
4630 o = newUNOP(leave_opcode, 0, (OP *) enterop);
4631
4632 if (cond) {
4633 enterop->op_first = scalar(cond);
4634 cond->op_sibling = block;
4635
4636 o->op_next = LINKLIST(cond);
4637 cond->op_next = (OP *) enterop;
4638 }
4639 else {
4640 /* This is a default {} block */
4641 enterop->op_first = block;
4642 enterop->op_flags |= OPf_SPECIAL;
4643
4644 o->op_next = (OP *) enterop;
4645 }
4646
4647 CHECKOP(enter_opcode, enterop); /* Currently does nothing, since
4648 entergiven and enterwhen both
4649 use ck_null() */
4650
4651 enterop->op_next = LINKLIST(block);
4652 block->op_next = enterop->op_other = o;
4653
4654 return o;
4655}
4656
4657/* Does this look like a boolean operation? For these purposes
4658 a boolean operation is:
4659 - a subroutine call [*]
4660 - a logical connective
4661 - a comparison operator
4662 - a filetest operator, with the exception of -s -M -A -C
4663 - defined(), exists() or eof()
4664 - /$re/ or $foo =~ /$re/
4665
4666 [*] possibly surprising
4667 */
4668STATIC
4669bool
ef519e13 4670S_looks_like_bool(pTHX_ const OP *o)
0d863452 4671{
97aff369 4672 dVAR;
0d863452
RH		 4673 switch(o->op_type) {
4674 case OP_OR:
4675 return looks_like_bool(cLOGOPo->op_first);
4676
4677 case OP_AND:
4678 return (
4679 looks_like_bool(cLOGOPo->op_first)
4680 && looks_like_bool(cLOGOPo->op_first->op_sibling));
4681
4682 case OP_ENTERSUB:
4683
4684 case OP_NOT: case OP_XOR:
4685 /* Note that OP_DOR is not here */
4686
4687 case OP_EQ: case OP_NE: case OP_LT:
4688 case OP_GT: case OP_LE: case OP_GE:
4689
4690 case OP_I_EQ: case OP_I_NE: case OP_I_LT:
4691 case OP_I_GT: case OP_I_LE: case OP_I_GE:
4692
4693 case OP_SEQ: case OP_SNE: case OP_SLT:
4694 case OP_SGT: case OP_SLE: case OP_SGE:
4695
4696 case OP_SMARTMATCH:
4697
4698 case OP_FTRREAD: case OP_FTRWRITE: case OP_FTREXEC:
4699 case OP_FTEREAD: case OP_FTEWRITE: case OP_FTEEXEC:
4700 case OP_FTIS: case OP_FTEOWNED: case OP_FTROWNED:
4701 case OP_FTZERO: case OP_FTSOCK: case OP_FTCHR:
4702 case OP_FTBLK: case OP_FTFILE: case OP_FTDIR:
4703 case OP_FTPIPE: case OP_FTLINK: case OP_FTSUID:
4704 case OP_FTSGID: case OP_FTSVTX: case OP_FTTTY:
4705 case OP_FTTEXT: case OP_FTBINARY:
4706
4707 case OP_DEFINED: case OP_EXISTS:
4708 case OP_MATCH: case OP_EOF:
4709
4710 return TRUE;
4711
4712 case OP_CONST:
4713 /* Detect comparisons that have been optimized away */
4714 if (cSVOPo->op_sv == &PL_sv_yes
4715 || cSVOPo->op_sv == &PL_sv_no)
4716
4717 return TRUE;
4718
4719 /* FALL THROUGH */
4720 default:
4721 return FALSE;
4722 }
4723}
4724
4725OP *
4726Perl_newGIVENOP(pTHX_ OP *cond, OP *block, PADOFFSET defsv_off)
4727{
97aff369 4728 dVAR;
0d863452
RH		 4729 assert( cond );
4730 return newGIVWHENOP(
4731 ref_array_or_hash(cond),
4732 block,
4733 OP_ENTERGIVEN, OP_LEAVEGIVEN,
4734 defsv_off);
4735}
4736
4737/* If cond is null, this is a default {} block */
4738OP *
4739Perl_newWHENOP(pTHX_ OP *cond, OP *block)
4740{
ef519e13 4741 const bool cond_llb = (!cond || looks_like_bool(cond));
0d863452
RH		 4742 OP *cond_op;
4743
4744 if (cond_llb)
4745 cond_op = cond;
4746 else {
4747 cond_op = newBINOP(OP_SMARTMATCH, OPf_SPECIAL,
4748 newDEFSVOP(),
4749 scalar(ref_array_or_hash(cond)));
4750 }
4751
4752 return newGIVWHENOP(
4753 cond_op,
4754 append_elem(block->op_type, block, newOP(OP_BREAK, OPf_SPECIAL)),
4755 OP_ENTERWHEN, OP_LEAVEWHEN, 0);
4756}
4757
7dafbf52
DM		 4758/*
4759=for apidoc cv_undef
4760
4761Clear out all the active components of a CV. This can happen either
4762by an explicit C<undef &foo>, or by the reference count going to zero.
4763In the former case, we keep the CvOUTSIDE pointer, so that any anonymous
4764children can still follow the full lexical scope chain.
4765
4766=cut
4767*/
4768
79072805 4769void
864dbfa3 4770Perl_cv_undef(pTHX_ CV *cv)
79072805 4771{
27da23d5 4772 dVAR;
a636914a 4773#ifdef USE_ITHREADS
aed2304a 4774 if (CvFILE(cv) && !CvISXSUB(cv)) {
35f1c1c7 4775 /* for XSUBs CvFILE point directly to static memory; __FILE__ */
a636914a 4776 Safefree(CvFILE(cv));
a636914a 4777 }
f3e31eb5 4778 CvFILE(cv) = 0;
a636914a
RH		 4779#endif
4780
aed2304a 4781 if (!CvISXSUB(cv) && CvROOT(cv)) {
bb172083 4782 if (SvTYPE(cv) == SVt_PVCV && CvDEPTH(cv))
cea2e8a9 4783 Perl_croak(aTHX_ "Can't undef active subroutine");
8990e307 4784 ENTER;
a0d0e21e 4785
f3548bdc 4786 PAD_SAVE_SETNULLPAD();
a0d0e21e 4787
282f25c9 4788 op_free(CvROOT(cv));
5f66b61c
AL		 4789 CvROOT(cv) = NULL;
4790 CvSTART(cv) = NULL;
8990e307 4791 LEAVE;
79072805 4792 }
1d5db326 4793 SvPOK_off((SV*)cv); /* forget prototype */
a0714e2c 4794 CvGV(cv) = NULL;
a3985cdc
DM		 4795
4796 pad_undef(cv);
4797
7dafbf52
DM		 4798 /* remove CvOUTSIDE unless this is an undef rather than a free */
4799 if (!SvREFCNT(cv) && CvOUTSIDE(cv)) {
4800 if (!CvWEAKOUTSIDE(cv))
4801 SvREFCNT_dec(CvOUTSIDE(cv));
601f1833 4802 CvOUTSIDE(cv) = NULL;
7dafbf52 4803 }
beab0874
JT		 4804 if (CvCONST(cv)) {
4805 SvREFCNT_dec((SV*)CvXSUBANY(cv).any_ptr);
4806 CvCONST_off(cv);
4807 }
d04ba589 4808 if (CvISXSUB(cv) && CvXSUB(cv)) {
96a5add6 4809 CvXSUB(cv) = NULL;
50762d59 4810 }
7dafbf52
DM		 4811 /* delete all flags except WEAKOUTSIDE */
4812 CvFLAGS(cv) &= CVf_WEAKOUTSIDE;
79072805
LW		 4813}
4814
3fe9a6f1 4815void
35a4481c 4816Perl_cv_ckproto(pTHX_ const CV *cv, const GV *gv, const char *p)
3fe9a6f1 4817{
b15aece3 4818 if (((!p != !SvPOK(cv)) || (p && strNE(p, SvPVX_const(cv)))) && ckWARN_d(WARN_PROTOTYPE)) {
2d03de9c 4819 SV* const msg = sv_newmortal();
a0714e2c 4820 SV* name = NULL;
3fe9a6f1 4821
4822 if (gv)
bd61b366 4823 gv_efullname3(name = sv_newmortal(), gv, NULL);
46fc3d4c 4824 sv_setpv(msg, "Prototype mismatch:");
4825 if (name)
894356b3 4826 Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, name);
3fe9a6f1 4827 if (SvPOK(cv))
e1ec3a88 4828 Perl_sv_catpvf(aTHX_ msg, " (%"SVf")", (const SV *)cv);
ebe643b9 4829 else
396482e1
GA		 4830 sv_catpvs(msg, ": none");
4831 sv_catpvs(msg, " vs ");
46fc3d4c 4832 if (p)
cea2e8a9 4833 Perl_sv_catpvf(aTHX_ msg, "(%s)", p);
46fc3d4c 4834 else
396482e1 4835 sv_catpvs(msg, "none");
9014280d 4836 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%"SVf, msg);
3fe9a6f1 4837 }
4838}
4839
35f1c1c7
SB		 4840static void const_sv_xsub(pTHX_ CV* cv);
4841
beab0874 4842/*
ccfc67b7
JH		 4843
4844=head1 Optree Manipulation Functions
4845
beab0874
JT		 4846=for apidoc cv_const_sv
4847
4848If C<cv> is a constant sub eligible for inlining. returns the constant
4849value returned by the sub. Otherwise, returns NULL.
4850
4851Constant subs can be created with C<newCONSTSUB> or as described in
4852L<perlsub/"Constant Functions">.
4853
4854=cut
4855*/
760ac839 4856SV *
864dbfa3 4857Perl_cv_const_sv(pTHX_ CV *cv)
760ac839 4858{
96a5add6 4859 PERL_UNUSED_CONTEXT;
5069cc75
NC		 4860 if (!cv)
4861 return NULL;
4862 if (!(SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM))
4863 return NULL;
4864 return CvCONST(cv) ? (SV*)CvXSUBANY(cv).any_ptr : NULL;
fe5e78ed 4865}
760ac839 4866
b5c19bd7
DM		 4867/* op_const_sv: examine an optree to determine whether it's in-lineable.
4868 * Can be called in 3 ways:
4869 *
4870 * !cv
4871 * look for a single OP_CONST with attached value: return the value
4872 *
4873 * cv && CvCLONE(cv) && !CvCONST(cv)
4874 *
4875 * examine the clone prototype, and if contains only a single
4876 * OP_CONST referencing a pad const, or a single PADSV referencing
4877 * an outer lexical, return a non-zero value to indicate the CV is
4878 * a candidate for "constizing" at clone time
4879 *
4880 * cv && CvCONST(cv)
4881 *
4882 * We have just cloned an anon prototype that was marked as a const
4883 * candidiate. Try to grab the current value, and in the case of
4884 * PADSV, ignore it if it has multiple references. Return the value.
4885 */
4886
fe5e78ed 4887SV *
6867be6d 4888Perl_op_const_sv(pTHX_ const OP *o, CV *cv)
fe5e78ed 4889{
97aff369 4890 dVAR;
a0714e2c 4891 SV *sv = NULL;
fe5e78ed 4892
0f79a09d 4893 if (!o)
a0714e2c 4894 return NULL;
1c846c1f
NIS		 4895
4896 if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
fe5e78ed
GS		 4897 o = cLISTOPo->op_first->op_sibling;
4898
4899 for (; o; o = o->op_next) {
890ce7af 4900 const OPCODE type = o->op_type;
fe5e78ed 4901
1c846c1f 4902 if (sv && o->op_next == o)
fe5e78ed 4903 return sv;
e576b457
JT		 4904 if (o->op_next != o) {
4905 if (type == OP_NEXTSTATE || type == OP_NULL || type == OP_PUSHMARK)
4906 continue;
4907 if (type == OP_DBSTATE)
4908 continue;
4909 }
54310121 4910 if (type == OP_LEAVESUB || type == OP_RETURN)
4911 break;
4912 if (sv)
a0714e2c 4913 return NULL;
7766f137 4914 if (type == OP_CONST && cSVOPo->op_sv)
5dc0d613 4915 sv = cSVOPo->op_sv;
b5c19bd7 4916 else if (cv && type == OP_CONST) {
dd2155a4 4917 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
beab0874 4918 if (!sv)
a0714e2c 4919 return NULL;
b5c19bd7
DM		 4920 }
4921 else if (cv && type == OP_PADSV) {
4922 if (CvCONST(cv)) { /* newly cloned anon */
4923 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
4924 /* the candidate should have 1 ref from this pad and 1 ref
4925 * from the parent */
4926 if (!sv || SvREFCNT(sv) != 2)
a0714e2c 4927 return NULL;
beab0874 4928 sv = newSVsv(sv);
b5c19bd7
DM		 4929 SvREADONLY_on(sv);
4930 return sv;
4931 }
4932 else {
4933 if (PAD_COMPNAME_FLAGS(o->op_targ) & SVf_FAKE)
4934 sv = &PL_sv_undef; /* an arbitrary non-null value */
beab0874 4935 }
760ac839 4936 }
b5c19bd7 4937 else {
a0714e2c 4938 return NULL;
b5c19bd7 4939 }
760ac839
LW		 4940 }
4941 return sv;
4942}
4943
eb8433b7
NC		 4944#ifdef PERL_MAD
4945OP *
4946#else
09bef843 4947void
eb8433b7 4948#endif
09bef843
SB		 4949Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4950{
99129197
NC		 4951#if 0
4952 /* This would be the return value, but the return cannot be reached. */
eb8433b7
NC		 4953 OP* pegop = newOP(OP_NULL, 0);
4954#endif
4955
46c461b5
AL		 4956 PERL_UNUSED_ARG(floor);
4957
09bef843
SB		 4958 if (o)
4959 SAVEFREEOP(o);
4960 if (proto)
4961 SAVEFREEOP(proto);
4962 if (attrs)
4963 SAVEFREEOP(attrs);
4964 if (block)
4965 SAVEFREEOP(block);
4966 Perl_croak(aTHX_ "\"my sub\" not yet implemented");
eb8433b7 4967#ifdef PERL_MAD
99129197 4968 NORETURN_FUNCTION_END;
eb8433b7 4969#endif
09bef843
SB		 4970}
4971
748a9306 4972CV *
864dbfa3 4973Perl_newSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *block)
79072805 4974{
5f66b61c 4975 return Perl_newATTRSUB(aTHX_ floor, o, proto, NULL, block);
09bef843
SB		 4976}
4977
4978CV *
4979Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4980{
27da23d5 4981 dVAR;
6867be6d 4982 const char *aname;
83ee9e09 4983 GV *gv;
5c144d81 4984 const char *ps;
ea6e9374 4985 STRLEN ps_len;
c445ea15 4986 register CV *cv = NULL;
beab0874 4987 SV *const_sv;
b48b272a
NC		 4988 /* If the subroutine has no body, no attributes, and no builtin attributes
4989 then it's just a sub declaration, and we may be able to get away with
4990 storing with a placeholder scalar in the symbol table, rather than a
4991 full GV and CV. If anything is present then it will take a full CV to
4992 store it. */
4993 const I32 gv_fetch_flags
eb8433b7
NC		 4994 = (block || attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)
4995 || PL_madskills)
b48b272a 4996 ? GV_ADDMULTI : GV_ADDMULTI | GV_NOINIT;
bd61b366 4997 const char * const name = o ? SvPVx_nolen_const(cSVOPo->op_sv) : NULL;
8e742a20
MHM		 4998
4999 if (proto) {
5000 assert(proto->op_type == OP_CONST);
5c144d81 5001 ps = SvPVx_const(((SVOP*)proto)->op_sv, ps_len);
8e742a20
MHM		 5002 }
5003 else
bd61b366 5004 ps = NULL;
8e742a20 5005
83ee9e09 5006 if (!name && PERLDB_NAMEANON && CopLINE(PL_curcop)) {
aec46f14 5007 SV * const sv = sv_newmortal();
c99da370
JH		 5008 Perl_sv_setpvf(aTHX_ sv, "%s[%s:%"IVdf"]",
5009 PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
83ee9e09 5010 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
b15aece3 5011 aname = SvPVX_const(sv);
83ee9e09
GS		 5012 }
5013 else
bd61b366 5014 aname = NULL;
61dbb99a 5015
61dbb99a 5016 gv = name ? gv_fetchsv(cSVOPo->op_sv, gv_fetch_flags, SVt_PVCV)
7a5fd60d
NC		 5017 : gv_fetchpv(aname ? aname
5018 : (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
61dbb99a 5019 gv_fetch_flags, SVt_PVCV);
83ee9e09 5020
eb8433b7
NC		 5021 if (!PL_madskills) {
5022 if (o)
5023 SAVEFREEOP(o);
5024 if (proto)
5025 SAVEFREEOP(proto);
5026 if (attrs)
5027 SAVEFREEOP(attrs);
5028 }
3fe9a6f1 5029
09bef843 5030 if (SvTYPE(gv) != SVt_PVGV) { /* Maybe prototype now, and had at
55d729e4
GS		 5031 maximum a prototype before. */
5032 if (SvTYPE(gv) > SVt_NULL) {
0453d815 5033 if (!SvPOK((SV*)gv) && !(SvIOK((SV*)gv) && SvIVX((SV*)gv) == -1)
e476b1b5 5034 && ckWARN_d(WARN_PROTOTYPE))
f248d071 5035 {
9014280d 5036 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "Runaway prototype");
f248d071 5037 }
55d729e4
GS		 5038 cv_ckproto((CV*)gv, NULL, ps);
5039 }
5040 if (ps)
ea6e9374 5041 sv_setpvn((SV*)gv, ps, ps_len);
55d729e4
GS		 5042 else
5043 sv_setiv((SV*)gv, -1);
3280af22
NIS		 5044 SvREFCNT_dec(PL_compcv);
5045 cv = PL_compcv = NULL;
5046 PL_sub_generation++;
beab0874 5047 goto done;
55d729e4
GS		 5048 }
5049
601f1833 5050 cv = (!name || GvCVGEN(gv)) ? NULL : GvCV(gv);
beab0874 5051
7fb37951
AMS		 5052#ifdef GV_UNIQUE_CHECK
5053 if (cv && GvUNIQUE(gv) && SvREADONLY(cv)) {
5054 Perl_croak(aTHX_ "Can't define subroutine %s (GV is unique)", name);
5bd07a3d
DM		 5055 }
5056#endif
5057
eb8433b7
NC		 5058 if (!block || !ps || *ps || attrs
5059 || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)
5060#ifdef PERL_MAD
5061 || block->op_type == OP_NULL
5062#endif
5063 )
a0714e2c 5064 const_sv = NULL;
beab0874 5065 else
601f1833 5066 const_sv = op_const_sv(block, NULL);
beab0874
JT		 5067
5068 if (cv) {
6867be6d 5069 const bool exists = CvROOT(cv) || CvXSUB(cv);
5bd07a3d 5070
7fb37951
AMS		 5071#ifdef GV_UNIQUE_CHECK
5072 if (exists && GvUNIQUE(gv)) {
5073 Perl_croak(aTHX_ "Can't redefine unique subroutine %s", name);
5bd07a3d
DM		 5074 }
5075#endif
5076
60ed1d8c
GS		 5077 /* if the subroutine doesn't exist and wasn't pre-declared
5078 * with a prototype, assume it will be AUTOLOADed,
5079 * skipping the prototype check
5080 */
5081 if (exists || SvPOK(cv))
01ec43d0 5082 cv_ckproto(cv, gv, ps);
68dc0745 5083 /* already defined (or promised)? */
60ed1d8c 5084 if (exists || GvASSUMECV(gv)) {
eb8433b7
NC		 5085 if ((!block
5086#ifdef PERL_MAD
5087 || block->op_type == OP_NULL
5088#endif
5089 )&& !attrs) {
d3cea301
SB		 5090 if (CvFLAGS(PL_compcv)) {
5091 /* might have had built-in attrs applied */
5092 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
5093 }
aa689395 5094 /* just a "sub foo;" when &foo is already defined */
3280af22 5095 SAVEFREESV(PL_compcv);
aa689395 5096 goto done;
5097 }
eb8433b7
NC		 5098 if (block
5099#ifdef PERL_MAD
5100 && block->op_type != OP_NULL
5101#endif
5102 ) {
beab0874
JT		 5103 if (ckWARN(WARN_REDEFINE)
5104 || (CvCONST(cv)
5105 && (!const_sv || sv_cmp(cv_const_sv(cv), const_sv))))
5106 {
6867be6d 5107 const line_t oldline = CopLINE(PL_curcop);
d8a34499
IK		 5108 if (PL_copline != NOLINE)
5109 CopLINE_set(PL_curcop, PL_copline);
9014280d 5110 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
beab0874
JT		 5111 CvCONST(cv) ? "Constant subroutine %s redefined"
5112 : "Subroutine %s redefined", name);
5113 CopLINE_set(PL_curcop, oldline);
5114 }
eb8433b7
NC		 5115#ifdef PERL_MAD
5116 if (!PL_minus_c) /* keep old one around for madskills */
5117#endif
5118 {
5119 /* (PL_madskills unset in used file.) */
5120 SvREFCNT_dec(cv);
5121 }
601f1833 5122 cv = NULL;
79072805 5123 }
79072805
LW		 5124 }
5125 }
beab0874 5126 if (const_sv) {
f84c484e 5127 SvREFCNT_inc_simple_void_NN(const_sv);
beab0874 5128 if (cv) {
0768512c 5129 assert(!CvROOT(cv) && !CvCONST(cv));
c69006e4 5130 sv_setpvn((SV*)cv, "", 0); /* prototype is "" */
beab0874
JT		 5131 CvXSUBANY(cv).any_ptr = const_sv;
5132 CvXSUB(cv) = const_sv_xsub;
5133 CvCONST_on(cv);
d04ba589 5134 CvISXSUB_on(cv);
beab0874
JT		 5135 }
5136 else {
601f1833 5137 GvCV(gv) = NULL;
beab0874
JT		 5138 cv = newCONSTSUB(NULL, name, const_sv);
5139 }
eb8433b7
NC		 5140 PL_sub_generation++;
5141 if (PL_madskills)
5142 goto install_block;
beab0874
JT		 5143 op_free(block);
5144 SvREFCNT_dec(PL_compcv);
5145 PL_compcv = NULL;
beab0874
JT		 5146 goto done;
5147 }
09bef843
SB		 5148 if (attrs) {
5149 HV *stash;
5150 SV *rcv;
5151
5152 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>
5153 * before we clobber PL_compcv.
5154 */
99129197 5155 if (cv && (!block
eb8433b7
NC		 5156#ifdef PERL_MAD
5157 || block->op_type == OP_NULL
5158#endif
5159 )) {
09bef843 5160 rcv = (SV*)cv;
020f0e03
SB		 5161 /* Might have had built-in attributes applied -- propagate them. */
5162 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
a9164de8 5163 if (CvGV(cv) && GvSTASH(CvGV(cv)))
09bef843 5164 stash = GvSTASH(CvGV(cv));
a9164de8 5165 else if (CvSTASH(cv))
09bef843
SB		 5166 stash = CvSTASH(cv);
5167 else
5168 stash = PL_curstash;
5169 }
5170 else {
5171 /* possibly about to re-define existing subr -- ignore old cv */
5172 rcv = (SV*)PL_compcv;
a9164de8 5173 if (name && GvSTASH(gv))
09bef843
SB		 5174 stash = GvSTASH(gv);
5175 else
5176 stash = PL_curstash;
5177 }
95f0a2f1 5178 apply_attrs(stash, rcv, attrs, FALSE);
09bef843 5179 }
a0d0e21e 5180 if (cv) { /* must reuse cv if autoloaded */
eb8433b7
NC		 5181 if (
5182#ifdef PERL_MAD
5183 (
5184#endif
5185 !block
5186#ifdef PERL_MAD
5187 || block->op_type == OP_NULL) && !PL_madskills
5188#endif
5189 ) {
09bef843
SB		 5190 /* got here with just attrs -- work done, so bug out */
5191 SAVEFREESV(PL_compcv);
5192 goto done;
5193 }
a3985cdc 5194 /* transfer PL_compcv to cv */
4633a7c4 5195 cv_undef(cv);
3280af22 5196 CvFLAGS(cv) = CvFLAGS(PL_compcv);
5c41a5fa
DM		 5197 if (!CvWEAKOUTSIDE(cv))
5198 SvREFCNT_dec(CvOUTSIDE(cv));
3280af22 5199 CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
a3985cdc 5200 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv);
3280af22
NIS		 5201 CvOUTSIDE(PL_compcv) = 0;
5202 CvPADLIST(cv) = CvPADLIST(PL_compcv);
5203 CvPADLIST(PL_compcv) = 0;
282f25c9 5204 /* inner references to PL_compcv must be fixed up ... */
dd2155a4 5205 pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
282f25c9 5206 /* ... before we throw it away */
3280af22 5207 SvREFCNT_dec(PL_compcv);
b5c19bd7 5208 PL_compcv = cv;
a933f601
IZ		 5209 if (PERLDB_INTER)/* Advice debugger on the new sub. */
5210 ++PL_sub_generation;
a0d0e21e
LW		 5211 }
5212 else {
3280af22 5213 cv = PL_compcv;
44a8e56a 5214 if (name) {
5215 GvCV(gv) = cv;
eb8433b7
NC		 5216 if (PL_madskills) {
5217 if (strEQ(name, "import")) {
5218 PL_formfeed = (SV*)cv;
5219 Perl_warner(aTHX_ packWARN(WARN_VOID), "%lx\n", (long)cv);
5220 }
5221 }
44a8e56a 5222 GvCVGEN(gv) = 0;
3280af22 5223 PL_sub_generation++;
44a8e56a 5224 }
a0d0e21e 5225 }
65c50114 5226 CvGV(cv) = gv;
a636914a 5227 CvFILE_set_from_cop(cv, PL_curcop);
3280af22 5228 CvSTASH(cv) = PL_curstash;
8990e307 5229
3fe9a6f1 5230 if (ps)
ea6e9374 5231 sv_setpvn((SV*)cv, ps, ps_len);
4633a7c4 5232
3280af22 5233 if (PL_error_count) {
c07a80fd 5234 op_free(block);
5f66b61c 5235 block = NULL;
68dc0745 5236 if (name) {
6867be6d 5237 const char *s = strrchr(name, ':');
68dc0745 5238 s = s ? s+1 : name;
6d4c2119 5239 if (strEQ(s, "BEGIN")) {
e1ec3a88 5240 const char not_safe[] =
6d4c2119 5241 "BEGIN not safe after errors--compilation aborted";
faef0170 5242 if (PL_in_eval & EVAL_KEEPERR)
cea2e8a9 5243 Perl_croak(aTHX_ not_safe);
6d4c2119
CS		 5244 else {
5245 /* force display of errors found but not reported */
38a03e6e 5246 sv_catpv(ERRSV, not_safe);
35c1215d 5247 Perl_croak(aTHX_ "%"SVf, ERRSV);
6d4c2119
CS		 5248 }
5249 }
68dc0745 5250 }
c07a80fd 5251 }
eb8433b7 5252 install_block:
beab0874
JT		 5253 if (!block)
5254 goto done;
a0d0e21e 5255
7766f137 5256 if (CvLVALUE(cv)) {
78f9721b
SM		 5257 CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0,
5258 mod(scalarseq(block), OP_LEAVESUBLV));
7766f137
GS		 5259 }
5260 else {
09c2fd24
AE		 5261 /* This makes sub {}; work as expected. */
5262 if (block->op_type == OP_STUB) {
eb8433b7
NC		 5263 OP* newblock = newSTATEOP(0, NULL, 0);
5264#ifdef PERL_MAD
5265 op_getmad(block,newblock,'B');
5266#else
09c2fd24 5267 op_free(block);
eb8433b7
NC		 5268#endif
5269 block = newblock;
09c2fd24 5270 }
7766f137
GS		 5271 CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block));
5272 }
5273 CvROOT(cv)->op_private |= OPpREFCOUNTED;
5274 OpREFCNT_set(CvROOT(cv), 1);
5275 CvSTART(cv) = LINKLIST(CvROOT(cv));
5276 CvROOT(cv)->op_next = 0;
a2efc822 5277 CALL_PEEP(CvSTART(cv));
7766f137
GS		 5278
5279 /* now that optimizer has done its work, adjust pad values */
54310121 5280
dd2155a4
DM		 5281 pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
5282
5283 if (CvCLONE(cv)) {
beab0874
JT		 5284 assert(!CvCONST(cv));
5285 if (ps && !*ps && op_const_sv(block, cv))
5286 CvCONST_on(cv);
a0d0e21e 5287 }
79072805 5288
83ee9e09 5289 if (name || aname) {
6867be6d 5290 const char *s;
0bd48802 5291 const char * const tname = (name ? name : aname);
44a8e56a 5292
3280af22 5293 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
561b68a9 5294 SV * const sv = newSV(0);
c4420975 5295 SV * const tmpstr = sv_newmortal();
5c1737d1
NC		 5296 GV * const db_postponed = gv_fetchpvs("DB::postponed",
5297 GV_ADDMULTI, SVt_PVHV);
44a8e56a 5298 HV *hv;
5299
ed094faf
GS		 5300 Perl_sv_setpvf(aTHX_ sv, "%s:%ld-%ld",
5301 CopFILE(PL_curcop),
cc49e20b 5302 (long)PL_subline, (long)CopLINE(PL_curcop));
bd61b366 5303 gv_efullname3(tmpstr, gv, NULL);
b15aece3 5304 hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr), SvCUR(tmpstr), sv, 0);
44a8e56a 5305 hv = GvHVn(db_postponed);
551405c4
AL		 5306 if (HvFILL(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvCUR(tmpstr))) {
5307 CV * const pcv = GvCV(db_postponed);
5308 if (pcv) {
5309 dSP;
5310 PUSHMARK(SP);
5311 XPUSHs(tmpstr);
5312 PUTBACK;
5313 call_sv((SV*)pcv, G_DISCARD);
5314 }
44a8e56a 5315 }
5316 }
79072805 5317
83ee9e09 5318 if ((s = strrchr(tname,':')))
28757baa 5319 s++;
5320 else
83ee9e09 5321 s = tname;
ed094faf 5322
7d30b5c4 5323 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
ed094faf
GS		 5324 goto done;
5325
7678c486 5326 if (strEQ(s, "BEGIN") && !PL_error_count) {
6867be6d 5327 const I32 oldscope = PL_scopestack_ix;
28757baa 5328 ENTER;
57843af0
GS		 5329 SAVECOPFILE(&PL_compiling);
5330 SAVECOPLINE(&PL_compiling);
28757baa 5331
3280af22
NIS		 5332 if (!PL_beginav)
5333 PL_beginav = newAV();
28757baa 5334 DEBUG_x( dump_sub(gv) );
ea2f84a3
GS		 5335 av_push(PL_beginav, (SV*)cv);
5336 GvCV(gv) = 0; /* cv has been hijacked */
3280af22 5337 call_list(oldscope, PL_beginav);
a6006777 5338
3280af22 5339 PL_curcop = &PL_compiling;
623e6609 5340 CopHINTS_set(&PL_compiling, PL_hints);
28757baa 5341 LEAVE;
5342 }
3280af22
NIS		 5343 else if (strEQ(s, "END") && !PL_error_count) {
5344 if (!PL_endav)
5345 PL_endav = newAV();
ed094faf 5346 DEBUG_x( dump_sub(gv) );
3280af22 5347 av_unshift(PL_endav, 1);
ea2f84a3
GS		 5348 av_store(PL_endav, 0, (SV*)cv);
5349 GvCV(gv) = 0; /* cv has been hijacked */
28757baa 5350 }
7d30b5c4
GS		 5351 else if (strEQ(s, "CHECK") && !PL_error_count) {
5352 if (!PL_checkav)
5353 PL_checkav = newAV();
ed094faf 5354 DEBUG_x( dump_sub(gv) );
ddda08b7 5355 if (PL_main_start && ckWARN(WARN_VOID))
9014280d 5356 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run CHECK block");
7d30b5c4 5357 av_unshift(PL_checkav, 1);
ea2f84a3
GS		 5358 av_store(PL_checkav, 0, (SV*)cv);
5359 GvCV(gv) = 0; /* cv has been hijacked */
4f25aa18 5360 }
3280af22
NIS		 5361 else if (strEQ(s, "INIT") && !PL_error_count) {
5362 if (!PL_initav)
5363 PL_initav = newAV();
ed094faf 5364 DEBUG_x( dump_sub(gv) );
ddda08b7 5365 if (PL_main_start && ckWARN(WARN_VOID))
9014280d 5366 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run INIT block");
ea2f84a3
GS		 5367 av_push(PL_initav, (SV*)cv);
5368 GvCV(gv) = 0; /* cv has been hijacked */
ae77835f 5369 }
79072805 5370 }
a6006777 5371
aa689395 5372 done:
3280af22 5373 PL_copline = NOLINE;
8990e307 5374 LEAVE_SCOPE(floor);
a0d0e21e 5375 return cv;
79072805
LW		 5376}
5377
b099ddc0 5378/* XXX unsafe for threads if eval_owner isn't held */
954c1994
GS		 5379/*
5380=for apidoc newCONSTSUB
5381
5382Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
5383eligible for inlining at compile-time.
5384
5385=cut
5386*/
5387
beab0874 5388CV *
e1ec3a88 5389Perl_newCONSTSUB(pTHX_ HV *stash, const char *name, SV *sv)
5476c433 5390{
27da23d5 5391 dVAR;
beab0874 5392 CV* cv;
5476c433 5393
11faa288 5394 ENTER;
11faa288 5395
f4dd75d9 5396 SAVECOPLINE(PL_curcop);
11faa288 5397 CopLINE_set(PL_curcop, PL_copline);
f4dd75d9
GS		 5398
5399 SAVEHINTS();
3280af22 5400 PL_hints &= ~HINT_BLOCK_SCOPE;
11faa288
GS		 5401
5402 if (stash) {
5403 SAVESPTR(PL_curstash);
5404 SAVECOPSTASH(PL_curcop);
5405 PL_curstash = stash;
05ec9bb3 5406 CopSTASH_set(PL_curcop,stash);
11faa288 5407 }
5476c433 5408
91a15d0d 5409 cv = newXS(name, const_sv_xsub, savepv(CopFILE(PL_curcop)));
beab0874
JT		 5410 CvXSUBANY(cv).any_ptr = sv;
5411 CvCONST_on(cv);
c69006e4 5412 sv_setpvn((SV*)cv, "", 0); /* prototype is "" */
5476c433 5413
65e66c80 5414#ifdef USE_ITHREADS
02f28d44
MHM		 5415 if (stash)
5416 CopSTASH_free(PL_curcop);
65e66c80 5417#endif
11faa288 5418 LEAVE;
beab0874
JT		 5419
5420 return cv;
5476c433
JD		 5421}
5422
954c1994
GS		 5423/*
5424=for apidoc U||newXS
5425
5426Used by C<xsubpp> to hook up XSUBs as Perl subs.
5427
5428=cut
5429*/
5430
57d3b86d 5431CV *
bfed75c6 5432Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename)
a0d0e21e 5433{
97aff369 5434 dVAR;
9a957fbc 5435 GV * const gv = gv_fetchpv(name ? name :
c99da370
JH		 5436 (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
5437 GV_ADDMULTI, SVt_PVCV);
79072805 5438 register CV *cv;
44a8e56a 5439
1ecdd9a8
HS		 5440 if (!subaddr)
5441 Perl_croak(aTHX_ "panic: no address for '%s' in '%s'", name, filename);
5442
601f1833 5443 if ((cv = (name ? GvCV(gv) : NULL))) {
44a8e56a 5444 if (GvCVGEN(gv)) {
5445 /* just a cached method */
5446 SvREFCNT_dec(cv);
601f1833 5447 cv = NULL;
44a8e56a 5448 }
5449 else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
5450 /* already defined (or promised) */
1df70142 5451 /* XXX It's possible for this HvNAME_get to return null, and get passed into strEQ */
66a1b24b
AL		 5452 if (ckWARN(WARN_REDEFINE)) {
5453 GV * const gvcv = CvGV(cv);
5454 if (gvcv) {
5455 HV * const stash = GvSTASH(gvcv);
5456 if (stash) {
8b38226b
AL		 5457 const char *redefined_name = HvNAME_get(stash);
5458 if ( strEQ(redefined_name,"autouse") ) {
66a1b24b
AL		 5459 const line_t oldline = CopLINE(PL_curcop);
5460 if (PL_copline != NOLINE)
5461 CopLINE_set(PL_curcop, PL_copline);
5462 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
5463 CvCONST(cv) ? "Constant subroutine %s redefined"
5464 : "Subroutine %s redefined"
5465 ,name);
5466 CopLINE_set(PL_curcop, oldline);
5467 }
5468 }
5469 }
a0d0e21e
LW		 5470 }
5471 SvREFCNT_dec(cv);
601f1833 5472 cv = NULL;
79072805 5473 }
79072805 5474 }
44a8e56a 5475
5476 if (cv) /* must reuse cv if autoloaded */
5477 cv_undef(cv);
a0d0e21e 5478 else {
561b68a9 5479 cv = (CV*)newSV(0);
a0d0e21e 5480 sv_upgrade((SV *)cv, SVt_PVCV);
44a8e56a 5481 if (name) {
5482 GvCV(gv) = cv;
5483 GvCVGEN(gv) = 0;
3280af22 5484 PL_sub_generation++;
44a8e56a 5485 }
a0d0e21e 5486 }
65c50114 5487 CvGV(cv) = gv;
b195d487 5488 (void)gv_fetchfile(filename);
dd374669 5489 CvFILE(cv) = (char *)filename; /* NOTE: not copied, as it is expected to be
57843af0 5490 an external constant string */
d04ba589 5491 CvISXSUB_on(cv);
a0d0e21e 5492 CvXSUB(cv) = subaddr;
44a8e56a 5493
28757baa 5494 if (name) {
e1ec3a88 5495 const char *s = strrchr(name,':');
28757baa 5496 if (s)
5497 s++;
5498 else
5499 s = name;
ed094faf 5500
7d30b5c4 5501 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
ed094faf
GS		 5502 goto done;
5503
28757baa 5504 if (strEQ(s, "BEGIN")) {
3280af22
NIS		 5505 if (!PL_beginav)
5506 PL_beginav = newAV();
ea2f84a3
GS		 5507 av_push(PL_beginav, (SV*)cv);
5508 GvCV(gv) = 0; /* cv has been hijacked */
28757baa 5509 }
5510 else if (strEQ(s, "END")) {
3280af22
NIS		 5511 if (!PL_endav)
5512 PL_endav = newAV();
5513 av_unshift(PL_endav, 1);
ea2f84a3
GS		 5514 av_store(PL_endav, 0, (SV*)cv);
5515 GvCV(gv) = 0; /* cv has been hijacked */
28757baa 5516 }
7d30b5c4
GS		 5517 else if (strEQ(s, "CHECK")) {
5518 if (!PL_checkav)
5519 PL_checkav = newAV();
ddda08b7 5520 if (PL_main_start && ckWARN(WARN_VOID))
9014280d 5521 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run CHECK block");
7d30b5c4 5522 av_unshift(PL_checkav, 1);
ea2f84a3
GS		 5523 av_store(PL_checkav, 0, (SV*)cv);
5524 GvCV(gv) = 0; /* cv has been hijacked */
4f25aa18 5525 }
7d07dbc2 5526 else if (strEQ(s, "INIT")) {
3280af22
NIS		 5527 if (!PL_initav)
5528 PL_initav = newAV();
ddda08b7 5529 if (PL_main_start && ckWARN(WARN_VOID))
9014280d 5530 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run INIT block");
ea2f84a3
GS		 5531 av_push(PL_initav, (SV*)cv);
5532 GvCV(gv) = 0; /* cv has been hijacked */
ae77835f 5533 }
28757baa 5534 }
8990e307 5535 else
a5f75d66 5536 CvANON_on(cv);
44a8e56a 5537
ed094faf 5538done:
a0d0e21e 5539 return cv;
79072805
LW		 5540}
5541
eb8433b7
NC		 5542#ifdef PERL_MAD
5543OP *
5544#else
79072805 5545void
eb8433b7 5546#endif
864dbfa3 5547Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
79072805 5548{
97aff369 5549 dVAR;
79072805 5550 register CV *cv;
eb8433b7
NC		 5551#ifdef PERL_MAD
5552 OP* pegop = newOP(OP_NULL, 0);
5553#endif
79072805 5554
0bd48802 5555 GV * const gv = o
f776e3cd 5556 ? gv_fetchsv(cSVOPo->op_sv, GV_ADD, SVt_PVFM)
fafc274c 5557 : gv_fetchpvs("STDOUT", GV_ADD|GV_NOTQUAL, SVt_PVFM);
0bd48802 5558
7fb37951
AMS		 5559#ifdef GV_UNIQUE_CHECK
5560 if (GvUNIQUE(gv)) {
5561 Perl_croak(aTHX_ "Bad symbol for form (GV is unique)");
5bd07a3d
DM		 5562 }
5563#endif
a5f75d66 5564 GvMULTI_on(gv);
155aba94 5565 if ((cv = GvFORM(gv))) {
599cee73 5566 if (ckWARN(WARN_REDEFINE)) {
6867be6d 5567 const line_t oldline = CopLINE(PL_curcop);
d8a34499
IK		 5568 if (PL_copline != NOLINE)
5569 CopLINE_set(PL_curcop, PL_copline);
7a5fd60d
NC		 5570 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
5571 o ? "Format %"SVf" redefined"
5572 : "Format STDOUT redefined" ,cSVOPo->op_sv);
57843af0 5573 CopLINE_set(PL_curcop, oldline);
79072805 5574 }
8990e307 5575 SvREFCNT_dec(cv);
79072805 5576 }
3280af22 5577 cv = PL_compcv;
79072805 5578 GvFORM(gv) = cv;
65c50114 5579 CvGV(cv) = gv;
a636914a 5580 CvFILE_set_from_cop(cv, PL_curcop);
79072805 5581
a0d0e21e 5582
dd2155a4 5583 pad_tidy(padtidy_FORMAT);
79072805 5584 CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
7934575e
GS		 5585 CvROOT(cv)->op_private |= OPpREFCOUNTED;
5586 OpREFCNT_set(CvROOT(cv), 1);
79072805
LW		 5587 CvSTART(cv) = LINKLIST(CvROOT(cv));
5588 CvROOT(cv)->op_next = 0;
a2efc822 5589 CALL_PEEP(CvSTART(cv));
eb8433b7
NC		 5590#ifdef PERL_MAD
5591 op_getmad(o,pegop,'n');
5592 op_getmad_weak(block, pegop, 'b');
5593#else
11343788 5594 op_free(o);
eb8433b7 5595#endif
3280af22 5596 PL_copline = NOLINE;
8990e307 5597 LEAVE_SCOPE(floor);
eb8433b7
NC		 5598#ifdef PERL_MAD
5599 return pegop;
5600#endif
79072805
LW		 5601}
5602
5603OP *
864dbfa3 5604Perl_newANONLIST(pTHX_ OP *o)
79072805 5605{
93a17b20 5606 return newUNOP(OP_REFGEN, 0,
11343788 5607 mod(list(convert(OP_ANONLIST, 0, o)), OP_REFGEN));
79072805
LW		 5608}
5609
5610OP *
864dbfa3 5611Perl_newANONHASH(pTHX_ OP *o)
79072805 5612{
93a17b20 5613 return newUNOP(OP_REFGEN, 0,
11343788 5614 mod(list(convert(OP_ANONHASH, 0, o)), OP_REFGEN));
a0d0e21e
LW		 5615}
5616
5617OP *
864dbfa3 5618Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
a0d0e21e 5619{
5f66b61c 5620 return newANONATTRSUB(floor, proto, NULL, block);
09bef843
SB		 5621}
5622
5623OP *
5624Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
5625{
a0d0e21e 5626 return newUNOP(OP_REFGEN, 0,
09bef843
SB		 5627 newSVOP(OP_ANONCODE, 0,
5628 (SV*)newATTRSUB(floor, 0, proto, attrs, block)));
79072805
LW		 5629}
5630
5631OP *
864dbfa3 5632Perl_oopsAV(pTHX_ OP *o)
79072805 5633{
27da23d5 5634 dVAR;
ed6116ce
LW		 5635 switch (o->op_type) {
5636 case OP_PADSV:
5637 o->op_type = OP_PADAV;
22c35a8c 5638 o->op_ppaddr = PL_ppaddr[OP_PADAV];
51e247a3 5639 return ref(o, OP_RV2AV);
b2ffa427 5640
ed6116ce 5641 case OP_RV2SV:
79072805 5642 o->op_type = OP_RV2AV;
22c35a8c 5643 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
79072805 5644 ref(o, OP_RV2AV);
ed6116ce
LW		 5645 break;
5646
5647 default:
0453d815 5648 if (ckWARN_d(WARN_INTERNAL))
9014280d 5649 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
ed6116ce
LW		 5650 break;
5651 }
79072805
LW		 5652 return o;
5653}
5654
5655OP *
864dbfa3 5656Perl_oopsHV(pTHX_ OP *o)
79072805 5657{
27da23d5 5658 dVAR;
ed6116ce
LW		 5659 switch (o->op_type) {
5660 case OP_PADSV:
5661 case OP_PADAV:
5662 o->op_type = OP_PADHV;
22c35a8c 5663 o->op_ppaddr = PL_ppaddr[OP_PADHV];
51e247a3 5664 return ref(o, OP_RV2HV);
ed6116ce
LW		 5665
5666 case OP_RV2SV:
5667 case OP_RV2AV:
79072805 5668 o->op_type = OP_RV2HV;
22c35a8c 5669 o->op_ppaddr = PL_ppaddr[OP_RV2HV];
79072805 5670 ref(o, OP_RV2HV);
ed6116ce
LW		 5671 break;
5672
5673 default:
0453d815 5674 if (ckWARN_d(WARN_INTERNAL))
9014280d 5675 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV");
ed6116ce
LW		 5676 break;
5677 }
79072805
LW		 5678 return o;
5679}
5680
5681OP *
864dbfa3 5682Perl_newAVREF(pTHX_ OP *o)
79072805 5683{
27da23d5 5684 dVAR;
ed6116ce
LW		 5685 if (o->op_type == OP_PADANY) {
5686 o->op_type = OP_PADAV;
22c35a8c 5687 o->op_ppaddr = PL_ppaddr[OP_PADAV];
93a17b20 5688 return o;
ed6116ce 5689 }
a1063b2d 5690 else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)
9014280d
PM		 5691 && ckWARN(WARN_DEPRECATED)) {
5692 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
a1063b2d
RH		 5693 "Using an array as a reference is deprecated");
5694 }
79072805
LW		 5695 return newUNOP(OP_RV2AV, 0, scalar(o));
5696}
5697
5698OP *
864dbfa3 5699Perl_newGVREF(pTHX_ I32 type, OP *o)
79072805 5700{
82092f1d 5701 if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
a0d0e21e 5702 return newUNOP(OP_NULL, 0, o);
748a9306 5703 return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
79072805
LW		 5704}
5705
5706OP *
864dbfa3 5707Perl_newHVREF(pTHX_ OP *o)
79072805 5708{
27da23d5 5709 dVAR;
ed6116ce
LW		 5710 if (o->op_type == OP_PADANY) {
5711 o->op_type = OP_PADHV;
22c35a8c 5712 o->op_ppaddr = PL_ppaddr[OP_PADHV];
93a17b20 5713 return o;
ed6116ce 5714 }
a1063b2d 5715 else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)
9014280d
PM		 5716 && ckWARN(WARN_DEPRECATED)) {
5717 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
a1063b2d
RH		 5718 "Using a hash as a reference is deprecated");
5719 }
79072805
LW		 5720 return newUNOP(OP_RV2HV, 0, scalar(o));
5721}
5722
5723OP *
864dbfa3 5724Perl_newCVREF(pTHX_ I32 flags, OP *o)
79072805 5725{
c07a80fd 5726 return newUNOP(OP_RV2CV, flags, scalar(o));
79072805
LW		 5727}
5728
5729OP *
864dbfa3 5730Perl_newSVREF(pTHX_ OP *o)
79072805 5731{
27da23d5 5732 dVAR;
ed6116ce
LW		 5733 if (o->op_type == OP_PADANY) {
5734 o->op_type = OP_PADSV;
22c35a8c 5735 o->op_ppaddr = PL_ppaddr[OP_PADSV];
93a17b20 5736 return o;
ed6116ce 5737 }
224a4551
MB		 5738 else if (o->op_type == OP_THREADSV && !(o->op_flags & OPpDONE_SVREF)) {
5739 o->op_flags |= OPpDONE_SVREF;
a863c7d1 5740 return o;
224a4551 5741 }
79072805
LW		 5742 return newUNOP(OP_RV2SV, 0, scalar(o));
5743}
5744
61b743bb
DM		 5745/* Check routines. See the comments at the top of this file for details
5746 * on when these are called */
79072805
LW		 5747
5748OP *
cea2e8a9 5749Perl_ck_anoncode(pTHX_ OP *o)
5f05dabc 5750{
dd2155a4 5751 cSVOPo->op_targ = pad_add_anon(cSVOPo->op_sv, o->op_type);
eb8433b7 5752 if (!PL_madskills)
1d866c12 5753 cSVOPo->op_sv = NULL;
5dc0d613 5754 return o;
5f05dabc 5755}
5756
5757OP *
cea2e8a9 5758Perl_ck_bitop(pTHX_ OP *o)
55497cff 5759{
97aff369 5760 dVAR;
276b2a0c
RGS		 5761#define OP_IS_NUMCOMPARE(op) \
5762 ((op) == OP_LT || (op) == OP_I_LT || \
5763 (op) == OP_GT || (op) == OP_I_GT || \
5764 (op) == OP_LE || (op) == OP_I_LE || \
5765 (op) == OP_GE || (op) == OP_I_GE || \
5766 (op) == OP_EQ || (op) == OP_I_EQ || \
5767 (op) == OP_NE || (op) == OP_I_NE || \
5768 (op) == OP_NCMP || (op) == OP_I_NCMP)
eb160463 5769 o->op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
2b84528b
RGS		 5770 if (!(o->op_flags & OPf_STACKED) /* Not an assignment */
5771 && (o->op_type == OP_BIT_OR
5772 || o->op_type == OP_BIT_AND
5773 || o->op_type == OP_BIT_XOR))
276b2a0c 5774 {
1df70142
AL		 5775 const OP * const left = cBINOPo->op_first;
5776 const OP * const right = left->op_sibling;
96a925ab
YST		 5777 if ((OP_IS_NUMCOMPARE(left->op_type) &&
5778 (left->op_flags & OPf_PARENS) == 0) ||
5779 (OP_IS_NUMCOMPARE(right->op_type) &&
5780 (right->op_flags & OPf_PARENS) == 0))
276b2a0c
RGS		 5781 if (ckWARN(WARN_PRECEDENCE))
5782 Perl_warner(aTHX_ packWARN(WARN_PRECEDENCE),
5783 "Possible precedence problem on bitwise %c operator",
5784 o->op_type == OP_BIT_OR ? '|'
5785 : o->op_type == OP_BIT_AND ? '&' : '^'
5786 );
5787 }
5dc0d613 5788 return o;
55497cff 5789}
5790
5791OP *
cea2e8a9 5792Perl_ck_concat(pTHX_ OP *o)
79072805 5793{
0bd48802 5794 const OP * const kid = cUNOPo->op_first;
96a5add6 5795 PERL_UNUSED_CONTEXT;
df91b2c5
AE		 5796 if (kid->op_type == OP_CONCAT && !(kid->op_private & OPpTARGET_MY) &&
5797 !(kUNOP->op_first->op_flags & OPf_MOD))
0165acc7 5798 o->op_flags |= OPf_STACKED;
11343788 5799 return o;
79072805
LW		 5800}
5801
5802OP *
cea2e8a9 5803Perl_ck_spair(pTHX_ OP *o)
79072805 5804{
27da23d5 5805 dVAR;
11343788 5806 if (o->op_flags & OPf_KIDS) {
79072805 5807 OP* newop;
a0d0e21e 5808 OP* kid;
6867be6d 5809 const OPCODE type = o->op_type;
5dc0d613 5810 o = modkids(ck_fun(o), type);
11343788 5811 kid = cUNOPo->op_first;
a0d0e21e
LW		 5812 newop = kUNOP->op_first->op_sibling;
5813 if (newop &&
5814 (newop->op_sibling ||
22c35a8c 5815 !(PL_opargs[newop->op_type] & OA_RETSCALAR) ||
a0d0e21e
LW		 5816 newop->op_type == OP_PADAV || newop->op_type == OP_PADHV ||
5817 newop->op_type == OP_RV2AV || newop->op_type == OP_RV2HV)) {
b2ffa427 5818
11343788 5819 return o;
a0d0e21e 5820 }
eb8433b7
NC		 5821#ifdef PERL_MAD
5822 op_getmad(kUNOP->op_first,newop,'K');
5823#else
a0d0e21e 5824 op_free(kUNOP->op_first);
eb8433b7 5825#endif
a0d0e21e
LW		 5826 kUNOP->op_first = newop;
5827 }
22c35a8c 5828 o->op_ppaddr = PL_ppaddr[++o->op_type];
11343788 5829 return ck_fun(o);
a0d0e21e
LW		 5830}
5831
5832OP *
cea2e8a9 5833Perl_ck_delete(pTHX_ OP *o)
a0d0e21e 5834{
11343788 5835 o = ck_fun(o);
5dc0d613 5836 o->op_private = 0;
11343788 5837 if (o->op_flags & OPf_KIDS) {
551405c4 5838 OP * const kid = cUNOPo->op_first;
01020589
GS		 5839 switch (kid->op_type) {
5840 case OP_ASLICE:
5841 o->op_flags |= OPf_SPECIAL;
5842 /* FALL THROUGH */
5843 case OP_HSLICE:
5dc0d613 5844 o->op_private |= OPpSLICE;
01020589
GS		 5845 break;
5846 case OP_AELEM:
5847 o->op_flags |= OPf_SPECIAL;
5848 /* FALL THROUGH */
5849 case OP_HELEM:
5850 break;
5851 default:
5852 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
53e06cf0 5853 OP_DESC(o));
01020589 5854 }
93c66552 5855 op_null(kid);
79072805 5856 }
11343788 5857 return o;
79072805
LW		 5858}
5859
5860OP *
96e176bf
CL		 5861Perl_ck_die(pTHX_ OP *o)
5862{
5863#ifdef VMS
5864 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
5865#endif
5866 return ck_fun(o);
5867}
5868
5869OP *
cea2e8a9 5870Perl_ck_eof(pTHX_ OP *o)
79072805 5871{
97aff369 5872 dVAR;
79072805 5873
11343788
MB		 5874 if (o->op_flags & OPf_KIDS) {
5875 if (cLISTOPo->op_first->op_type == OP_STUB) {
1d866c12
AL		 5876 OP * const newop
5877 = newUNOP(o->op_type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv));
eb8433b7
NC		 5878#ifdef PERL_MAD
5879 op_getmad(o,newop,'O');
5880#else
11343788 5881 op_free(o);
eb8433b7
NC		 5882#endif
5883 o = newop;
8990e307 5884 }
11343788 5885 return ck_fun(o);
79072805 5886 }
11343788 5887 return o;
79072805
LW		 5888}
5889
5890OP *
cea2e8a9 5891Perl_ck_eval(pTHX_ OP *o)
79072805 5892{
27da23d5 5893 dVAR;
3280af22 5894 PL_hints |= HINT_BLOCK_SCOPE;
11343788 5895 if (o->op_flags & OPf_KIDS) {
46c461b5 5896 SVOP * const kid = (SVOP*)cUNOPo->op_first;
79072805 5897
93a17b20 5898 if (!kid) {
11343788 5899 o->op_flags &= ~OPf_KIDS;
93c66552 5900 op_null(o);
79072805 5901 }
b14574b4 5902 else if (kid->op_type == OP_LINESEQ || kid->op_type == OP_STUB) {
79072805 5903 LOGOP *enter;
eb8433b7 5904#ifdef PERL_MAD
1d866c12 5905 OP* const oldo = o;
eb8433b7 5906#endif
79072805 5907
11343788 5908 cUNOPo->op_first = 0;
eb8433b7 5909#ifndef PERL_MAD
11343788 5910 op_free(o);
eb8433b7 5911#endif
79072805 5912
b7dc083c 5913 NewOp(1101, enter, 1, LOGOP);
79072805 5914 enter->op_type = OP_ENTERTRY;
22c35a8c 5915 enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
79072805
LW		 5916 enter->op_private = 0;
5917
5918 /* establish postfix order */
5919 enter->op_next = (OP*)enter;
5920
11343788
MB		 5921 o = prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
5922 o->op_type = OP_LEAVETRY;
22c35a8c 5923 o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
11343788 5924 enter->op_other = o;
eb8433b7 5925 op_getmad(oldo,o,'O');
11343788 5926 return o;
79072805 5927 }
b5c19bd7 5928 else {
473986ff 5929 scalar((OP*)kid);
b5c19bd7
DM		 5930 PL_cv_has_eval = 1;
5931 }
79072805
LW		 5932 }
5933 else {
eb8433b7 5934#ifdef PERL_MAD
1d866c12 5935 OP* const oldo = o;
eb8433b7 5936#else
11343788 5937 op_free(o);
eb8433b7 5938#endif
54b9620d 5939 o = newUNOP(OP_ENTEREVAL, 0, newDEFSVOP());
eb8433b7 5940 op_getmad(oldo,o,'O');
79072805 5941 }
3280af22 5942 o->op_targ = (PADOFFSET)PL_hints;
7168684c 5943 if ((PL_hints & HINT_LOCALIZE_HH) != 0 && GvHV(PL_hintgv)) {
0d863452 5944 /* Store a copy of %^H that pp_entereval can pick up */
5b9c0671
NC		 5945 OP *hhop = newSVOP(OP_CONST, 0,
5946 (SV*)Perl_hv_copy_hints_hv(aTHX_ GvHV(PL_hintgv)));
0d863452
RH		 5947 cUNOPo->op_first->op_sibling = hhop;
5948 o->op_private |= OPpEVAL_HAS_HH;
5949 }
11343788 5950 return o;
79072805
LW		 5951}
5952
5953OP *
d98f61e7
GS		 5954Perl_ck_exit(pTHX_ OP *o)
5955{
5956#ifdef VMS
551405c4 5957 HV * const table = GvHV(PL_hintgv);
d98f61e7 5958 if (table) {
a4fc7abc 5959 SV * const * const svp = hv_fetchs(table, "vmsish_exit", FALSE);
d98f61e7
GS		 5960 if (svp && *svp && SvTRUE(*svp))
5961 o->op_private |= OPpEXIT_VMSISH;
5962 }
96e176bf 5963 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
d98f61e7
GS		 5964#endif
5965 return ck_fun(o);
5966}
5967
5968OP *
cea2e8a9 5969Perl_ck_exec(pTHX_ OP *o)
79072805 5970{
11343788 5971 if (o->op_flags & OPf_STACKED) {
6867be6d 5972 OP *kid;
11343788
MB		 5973 o = ck_fun(o);
5974 kid = cUNOPo->op_first->op_sibling;
8990e307 5975 if (kid->op_type == OP_RV2GV)
93c66552 5976 op_null(kid);
79072805 5977 }
463ee0b2 5978 else
11343788
MB		 5979 o = listkids(o);
5980 return o;
79072805
LW		 5981}
5982
5983OP *
cea2e8a9 5984Perl_ck_exists(pTHX_ OP *o)
5f05dabc 5985{
97aff369 5986 dVAR;
5196be3e
MB		 5987 o = ck_fun(o);
5988 if (o->op_flags & OPf_KIDS) {
46c461b5 5989 OP * const kid = cUNOPo->op_first;
afebc493
GS		 5990 if (kid->op_type == OP_ENTERSUB) {
5991 (void) ref(kid, o->op_type);
5992 if (kid->op_type != OP_RV2CV && !PL_error_count)
5993 Perl_croak(aTHX_ "%s argument is not a subroutine name",
53e06cf0 5994 OP_DESC(o));
afebc493
GS		 5995 o->op_private |= OPpEXISTS_SUB;
5996 }
5997 else if (kid->op_type == OP_AELEM)
01020589
GS		 5998 o->op_flags |= OPf_SPECIAL;
5999 else if (kid->op_type != OP_HELEM)
6000 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element",
53e06cf0 6001 OP_DESC(o));
93c66552 6002 op_null(kid);
5f05dabc 6003 }
5196be3e 6004 return o;
5f05dabc 6005}
6006
79072805 6007OP *
cea2e8a9 6008Perl_ck_rvconst(pTHX_ register OP *o)
79072805 6009{
27da23d5 6010 dVAR;
0bd48802 6011 SVOP * const kid = (SVOP*)cUNOPo->op_first;
85e6fe83 6012
3280af22 6013 o->op_private |= (PL_hints & HINT_STRICT_REFS);
e26df76a
NC		 6014 if (o->op_type == OP_RV2CV)
6015 o->op_private &= ~1;
6016
79072805 6017 if (kid->op_type == OP_CONST) {
44a8e56a 6018 int iscv;
6019 GV *gv;
504618e9 6020 SV * const kidsv = kid->op_sv;
44a8e56a 6021
779c5bc9
GS		 6022 /* Is it a constant from cv_const_sv()? */
6023 if (SvROK(kidsv) && SvREADONLY(kidsv)) {
0bd48802 6024 SV * const rsv = SvRV(kidsv);
504618e9 6025 const int svtype = SvTYPE(rsv);
bd61b366 6026 const char *badtype = NULL;
779c5bc9
GS		 6027
6028 switch (o->op_type) {
6029 case OP_RV2SV:
6030 if (svtype > SVt_PVMG)
6031 badtype = "a SCALAR";
6032 break;
6033 case OP_RV2AV:
6034 if (svtype != SVt_PVAV)
6035 badtype = "an ARRAY";
6036 break;
6037 case OP_RV2HV:
6d822dc4 6038 if (svtype != SVt_PVHV)
779c5bc9 6039 badtype = "a HASH";
779c5bc9
GS		 6040 break;
6041 case OP_RV2CV:
6042 if (svtype != SVt_PVCV)
6043 badtype = "a CODE";
6044 break;
6045 }
6046 if (badtype)
cea2e8a9 6047 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
779c5bc9
GS		 6048 return o;
6049 }
ce10b5d1
RGS		 6050 else if ((o->op_type == OP_RV2HV || o->op_type == OP_RV2SV) &&
6051 (PL_hints & HINT_STRICT_REFS) && SvPOK(kidsv)) {
6052 /* If this is an access to a stash, disable "strict refs", because
6053 * stashes aren't auto-vivified at compile-time (unless we store
6054 * symbols in them), and we don't want to produce a run-time
6055 * stricture error when auto-vivifying the stash. */
6056 const char *s = SvPV_nolen(kidsv);
6057 const STRLEN l = SvCUR(kidsv);
6058 if (l > 1 && s[l-1] == ':' && s[l-2] == ':')
6059 o->op_private &= ~HINT_STRICT_REFS;
6060 }
6061 if ((o->op_private & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
5f66b61c 6062 const char *badthing;
5dc0d613 6063 switch (o->op_type) {
44a8e56a 6064 case OP_RV2SV:
6065 badthing = "a SCALAR";
6066 break;
6067 case OP_RV2AV:
6068 badthing = "an ARRAY";
6069 break;
6070 case OP_RV2HV:
6071 badthing = "a HASH";
6072 break;
5f66b61c
AL		 6073 default:
6074 badthing = NULL;
6075 break;
44a8e56a 6076 }
6077 if (badthing)
1c846c1f 6078 Perl_croak(aTHX_
7a5fd60d
NC		 6079 "Can't use bareword (\"%"SVf"\") as %s ref while \"strict refs\" in use",
6080 kidsv, badthing);
44a8e56a 6081 }
93233ece
CS		 6082 /*
6083 * This is a little tricky. We only want to add the symbol if we
6084 * didn't add it in the lexer. Otherwise we get duplicate strict
6085 * warnings. But if we didn't add it in the lexer, we must at
6086 * least pretend like we wanted to add it even if it existed before,
6087 * or we get possible typo warnings. OPpCONST_ENTERED says
6088 * whether the lexer already added THIS instance of this symbol.
6089 */
5196be3e 6090 iscv = (o->op_type == OP_RV2CV) * 2;
93233ece 6091 do {
7a5fd60d 6092 gv = gv_fetchsv(kidsv,
748a9306 6093 iscv | !(kid->op_private & OPpCONST_ENTERED),
a0d0e21e
LW		 6094 iscv
6095 ? SVt_PVCV
11343788 6096 : o->op_type == OP_RV2SV
a0d0e21e 6097 ? SVt_PV
11343788 6098 : o->op_type == OP_RV2AV
a0d0e21e 6099 ? SVt_PVAV
11343788 6100 : o->op_type == OP_RV2HV
a0d0e21e
LW		 6101 ? SVt_PVHV
6102 : SVt_PVGV);
93233ece
CS		 6103 } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
6104 if (gv) {
6105 kid->op_type = OP_GV;
6106 SvREFCNT_dec(kid->op_sv);
350de78d 6107#ifdef USE_ITHREADS
638eceb6 6108 /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
350de78d 6109 kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
dd2155a4 6110 SvREFCNT_dec(PAD_SVl(kPADOP->op_padix));
743e66e6 6111 GvIN_PAD_on(gv);
b37c2d43 6112 PAD_SETSV(kPADOP->op_padix, (SV*) SvREFCNT_inc_simple_NN(gv));
350de78d 6113#else
b37c2d43 6114 kid->op_sv = SvREFCNT_inc_simple_NN(gv);
350de78d 6115#endif
23f1ca44 6116 kid->op_private = 0;
76cd736e 6117 kid->op_ppaddr = PL_ppaddr[OP_GV];
a0d0e21e 6118 }
79072805 6119 }
11343788 6120 return o;
79072805
LW		 6121}
6122
6123OP *
cea2e8a9 6124Perl_ck_ftst(pTHX_ OP *o)
79072805 6125{
27da23d5 6126 dVAR;
6867be6d 6127 const I32 type = o->op_type;
79072805 6128
d0dca557 6129 if (o->op_flags & OPf_REF) {
bb263b4e 6130 /*EMPTY*/;
d0dca557
JD		 6131 }
6132 else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
551405c4 6133 SVOP * const kid = (SVOP*)cUNOPo->op_first;
79072805
LW		 6134
6135 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
551405c4 6136 OP * const newop = newGVOP(type, OPf_REF,
f776e3cd 6137 gv_fetchsv(kid->op_sv, GV_ADD, SVt_PVIO));
eb8433b7
NC		 6138#ifdef PERL_MAD
6139 op_getmad(o,newop,'O');
6140#else
11343788 6141 op_free(o);
eb8433b7 6142#endif
1d866c12 6143 return newop;
79072805 6144 }
1d866c12 6145 if ((PL_hints & HINT_FILETEST_ACCESS) && OP_IS_FILETEST_ACCESS(o))
1af34c76 6146 o->op_private |= OPpFT_ACCESS;
fbb0b3b3
RGS		 6147 if (PL_check[kid->op_type] == MEMBER_TO_FPTR(Perl_ck_ftst)
6148 && kid->op_type != OP_STAT && kid->op_type != OP_LSTAT)
6149 o->op_private |= OPpFT_STACKED;
79072805
LW		 6150 }
6151 else {
eb8433b7 6152#ifdef PERL_MAD
1d866c12 6153 OP* const oldo = o;
eb8433b7 6154#else
11343788 6155 op_free(o);
eb8433b7 6156#endif
79072805 6157 if (type == OP_FTTTY)
8fde6460 6158 o = newGVOP(type, OPf_REF, PL_stdingv);
79072805 6159 else
d0dca557 6160 o = newUNOP(type, 0, newDEFSVOP());
eb8433b7 6161 op_getmad(oldo,o,'O');
79072805 6162 }
11343788 6163 return o;
79072805
LW		 6164}
6165
6166OP *
cea2e8a9 6167Perl_ck_fun(pTHX_ OP *o)
79072805 6168{
97aff369 6169 dVAR;
6867be6d 6170 const int type = o->op_type;
22c35a8c 6171 register I32 oa = PL_opargs[type] >> OASHIFT;
aeea060c 6172
11343788 6173 if (o->op_flags & OPf_STACKED) {
79072805
LW		 6174 if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
6175 oa &= ~OA_OPTIONAL;
6176 else
11343788 6177 return no_fh_allowed(o);
79072805
LW		 6178 }
6179
11343788 6180 if (o->op_flags & OPf_KIDS) {
6867be6d
AL		 6181 OP **tokid = &cLISTOPo->op_first;
6182 register OP *kid = cLISTOPo->op_first;
6183 OP *sibl;
6184 I32 numargs = 0;
6185
8990e307 6186 if (kid->op_type == OP_PUSHMARK ||
155aba94 6187 (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
8990e307 6188 {
79072805
LW		 6189 tokid = &kid->op_sibling;
6190 kid = kid->op_sibling;
6191 }
22c35a8c 6192 if (!kid && PL_opargs[type] & OA_DEFGV)
54b9620d 6193 *tokid = kid = newDEFSVOP();
79072805
LW		 6194
6195 while (oa && kid) {
6196 numargs++;
6197 sibl = kid->op_sibling;
eb8433b7
NC		 6198#ifdef PERL_MAD
6199 if (!sibl && kid->op_type == OP_STUB) {
6200 numargs--;
6201 break;
6202 }
6203#endif
79072805
LW		 6204 switch (oa & 7) {
6205 case OA_SCALAR:
62c18ce2
GS		 6206 /* list seen where single (scalar) arg expected? */
6207 if (numargs == 1 && !(oa >> 4)
6208 && kid->op_type == OP_LIST && type != OP_SCALAR)
6209 {
6210 return too_many_arguments(o,PL_op_desc[type]);
6211 }
79072805
LW		 6212 scalar(kid);
6213 break;
6214 case OA_LIST:
6215 if (oa < 16) {
6216 kid = 0;
6217 continue;
6218 }
6219 else
6220 list(kid);
6221 break;
6222 case OA_AVREF:
936edb8b 6223 if ((type == OP_PUSH || type == OP_UNSHIFT)
f87c3213 6224 && !kid->op_sibling && ckWARN(WARN_SYNTAX))
9014280d 6225 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
de4864e4 6226 "Useless use of %s with no values",
936edb8b 6227 PL_op_desc[type]);
b2ffa427 6228
79072805 6229 if (kid->op_type == OP_CONST &&
62c18ce2
GS		 6230 (kid->op_private & OPpCONST_BARE))
6231 {
551405c4 6232 OP * const newop = newAVREF(newGVOP(OP_GV, 0,
f776e3cd 6233 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVAV) ));
12bcd1a6
PM		 6234 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
6235 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
7a5fd60d
NC		 6236 "Array @%"SVf" missing the @ in argument %"IVdf" of %s()",
6237 ((SVOP*)kid)->op_sv, (IV)numargs, PL_op_desc[type]);
eb8433b7
NC		 6238#ifdef PERL_MAD
6239 op_getmad(kid,newop,'K');
6240#else
79072805 6241 op_free(kid);
eb8433b7 6242#endif
79072805
LW		 6243 kid = newop;
6244 kid->op_sibling = sibl;
6245 *tokid = kid;
6246 }
8990e307 6247 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV)
35cd451c 6248 bad_type(numargs, "array", PL_op_desc[type], kid);
a0d0e21e 6249 mod(kid, type);
79072805
LW		 6250 break;
6251 case OA_HVREF:
6252 if (kid->op_type == OP_CONST &&
62c18ce2
GS		 6253 (kid->op_private & OPpCONST_BARE))
6254 {
551405c4 6255 OP * const newop = newHVREF(newGVOP(OP_GV, 0,
f776e3cd 6256 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVHV) ));
12bcd1a6
PM		 6257 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
6258 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
7a5fd60d
NC		 6259 "Hash %%%"SVf" missing the %% in argument %"IVdf" of %s()",
6260 ((SVOP*)kid)->op_sv, (IV)numargs, PL_op_desc[type]);
eb8433b7
NC		 6261#ifdef PERL_MAD
6262 op_getmad(kid,newop,'K');
6263#else
79072805 6264 op_free(kid);
eb8433b7 6265#endif
79072805
LW		 6266 kid = newop;
6267 kid->op_sibling = sibl;
6268 *tokid = kid;
6269 }
8990e307 6270 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
35cd451c 6271 bad_type(numargs, "hash", PL_op_desc[type], kid);
a0d0e21e 6272 mod(kid, type);
79072805
LW		 6273 break;
6274 case OA_CVREF:
6275 {
551405c4 6276 OP * const newop = newUNOP(OP_NULL, 0, kid);
79072805
LW		 6277 kid->op_sibling = 0;
6278 linklist(kid);
6279 newop->op_next = newop;
6280 kid = newop;
6281 kid->op_sibling = sibl;
6282 *tokid = kid;
6283 }
6284 break;
6285 case OA_FILEREF:
c340be78 6286 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
79072805 6287 if (kid->op_type == OP_CONST &&
62c18ce2
GS		 6288 (kid->op_private & OPpCONST_BARE))
6289 {
0bd48802 6290 OP * const newop = newGVOP(OP_GV, 0,
f776e3cd 6291 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVIO));
afbdacea 6292 if (!(o->op_private & 1) && /* if not unop */
8a996ce8 6293 kid == cLISTOPo->op_last)
364daeac 6294 cLISTOPo->op_last = newop;
eb8433b7
NC		 6295#ifdef PERL_MAD
6296 op_getmad(kid,newop,'K');
6297#else
79072805 6298 op_free(kid);
eb8433b7 6299#endif
79072805
LW		 6300 kid = newop;
6301 }
1ea32a52
GS		 6302 else if (kid->op_type == OP_READLINE) {
6303 /* neophyte patrol: open(<FH>), close(<FH>) etc. */
53e06cf0 6304 bad_type(numargs, "HANDLE", OP_DESC(o), kid);
1ea32a52 6305 }
79072805 6306 else {
35cd451c 6307 I32 flags = OPf_SPECIAL;
a6c40364 6308 I32 priv = 0;
2c8ac474
GS		 6309 PADOFFSET targ = 0;
6310
35cd451c 6311 /* is this op a FH constructor? */
853846ea 6312 if (is_handle_constructor(o,numargs)) {
bd61b366 6313 const char *name = NULL;
dd2155a4 6314 STRLEN len = 0;
2c8ac474
GS		 6315
6316 flags = 0;
6317 /* Set a flag to tell rv2gv to vivify
853846ea
NIS		 6318 * need to "prove" flag does not mean something
6319 * else already - NI-S 1999/05/07
2c8ac474
GS		 6320 */
6321 priv = OPpDEREF;
6322 if (kid->op_type == OP_PADSV) {
dd2155a4
DM		 6323 name = PAD_COMPNAME_PV(kid->op_targ);
6324 /* SvCUR of a pad namesv can't be trusted
6325 * (see PL_generation), so calc its length
6326 * manually */
6327 if (name)
6328 len = strlen(name);
6329
2c8ac474
GS		 6330 }
6331 else if (kid->op_type == OP_RV2SV
6332 && kUNOP->op_first->op_type == OP_GV)
6333 {
0bd48802 6334 GV * const gv = cGVOPx_gv(kUNOP->op_first);
2c8ac474
GS		 6335 name = GvNAME(gv);
6336 len = GvNAMELEN(gv);
6337 }
afd1915d
GS		 6338 else if (kid->op_type == OP_AELEM
6339 || kid->op_type == OP_HELEM)
6340 {
551405c4 6341 OP *op = ((BINOP*)kid)->op_first;
a4fc7abc 6342 name = NULL;
551405c4 6343 if (op) {
a0714e2c 6344 SV *tmpstr = NULL;
551405c4 6345 const char * const a =
0c4b0a3f
JH		 6346 kid->op_type == OP_AELEM ?
6347 "[]" : "{}";
6348 if (((op->op_type == OP_RV2AV) ||
6349 (op->op_type == OP_RV2HV)) &&
6350 (op = ((UNOP*)op)->op_first) &&
6351 (op->op_type == OP_GV)) {
6352 /* packagevar $a[] or $h{} */
551405c4 6353 GV * const gv = cGVOPx_gv(op);
0c4b0a3f
JH		 6354 if (gv)
6355 tmpstr =
6356 Perl_newSVpvf(aTHX_
6357 "%s%c...%c",
6358 GvNAME(gv),
6359 a[0], a[1]);
6360 }
6361 else if (op->op_type == OP_PADAV
6362 || op->op_type == OP_PADHV) {
6363 /* lexicalvar $a[] or $h{} */
551405c4 6364 const char * const padname =
0c4b0a3f
JH		 6365 PAD_COMPNAME_PV(op->op_targ);
6366 if (padname)
6367 tmpstr =
6368 Perl_newSVpvf(aTHX_
6369 "%s%c...%c",
6370 padname + 1,
6371 a[0], a[1]);
0c4b0a3f
JH		 6372 }
6373 if (tmpstr) {
93524f2b 6374 name = SvPV_const(tmpstr, len);
0c4b0a3f
JH		 6375 sv_2mortal(tmpstr);
6376 }
6377 }
6378 if (!name) {
6379 name = "__ANONIO__";
6380 len = 10;
6381 }
6382 mod(kid, type);
afd1915d 6383 }
2c8ac474
GS		 6384 if (name) {
6385 SV *namesv;
6386 targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
dd2155a4 6387 namesv = PAD_SVl(targ);
862a34c6 6388 SvUPGRADE(namesv, SVt_PV);
2c8ac474
GS		 6389 if (*name != '$')
6390 sv_setpvn(namesv, "$", 1);
6391 sv_catpvn(namesv, name, len);
6392 }
853846ea 6393 }
79072805 6394 kid->op_sibling = 0;
35cd451c 6395 kid = newUNOP(OP_RV2GV, flags, scalar(kid));
2c8ac474
GS		 6396 kid->op_targ = targ;
6397 kid->op_private |= priv;
79072805
LW		 6398 }
6399 kid->op_sibling = sibl;
6400 *tokid = kid;
6401 }
6402 scalar(kid);
6403 break;
6404 case OA_SCALARREF:
a0d0e21e 6405 mod(scalar(kid), type);
79072805
LW		 6406 break;
6407 }
6408 oa >>= 4;
6409 tokid = &kid->op_sibling;
6410 kid = kid->op_sibling;
6411 }
eb8433b7
NC		 6412#ifdef PERL_MAD
6413 if (kid && kid->op_type != OP_STUB)
6414 return too_many_arguments(o,OP_DESC(o));
6415 o->op_private |= numargs;
6416#else
6417 /* FIXME - should the numargs move as for the PERL_MAD case? */
11343788 6418 o->op_private |= numargs;
79072805 6419 if (kid)
53e06cf0 6420 return too_many_arguments(o,OP_DESC(o));
eb8433b7 6421#endif
11343788 6422 listkids(o);
79072805 6423 }
22c35a8c 6424 else if (PL_opargs[type] & OA_DEFGV) {
c56915e3 6425#ifdef PERL_MAD
c7fe699d 6426 OP *newop = newUNOP(type, 0, newDEFSVOP());
c56915e3 6427 op_getmad(o,newop,'O');
c7fe699d 6428 return newop;
c56915e3 6429#else
c7fe699d 6430 /* Ordering of these two is important to keep f_map.t passing. */
11343788 6431 op_free(o);
c7fe699d 6432 return newUNOP(type, 0, newDEFSVOP());
c56915e3 6433#endif
a0d0e21e
LW		 6434 }
6435
79072805
LW		 6436 if (oa) {
6437 while (oa & OA_OPTIONAL)
6438 oa >>= 4;
6439 if (oa && oa != OA_LIST)
53e06cf0 6440 return too_few_arguments(o,OP_DESC(o));
79072805 6441 }
11343788 6442 return o;
79072805
LW		 6443}
6444
6445OP *
cea2e8a9 6446Perl_ck_glob(pTHX_ OP *o)
79072805 6447{
27da23d5 6448 dVAR;
fb73857a 6449 GV *gv;
6450
649da076 6451 o = ck_fun(o);
1f2bfc8a 6452 if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
54b9620d 6453 append_elem(OP_GLOB, o, newDEFSVOP());
fb73857a 6454
fafc274c 6455 if (!((gv = gv_fetchpvs("glob", GV_NOTQUAL, SVt_PVCV))
b9f751c0
GS		 6456 && GvCVu(gv) && GvIMPORTED_CV(gv)))
6457 {
5c1737d1 6458 gv = gv_fetchpvs("CORE::GLOBAL::glob", 0, SVt_PVCV);
b9f751c0 6459 }
b1cb66bf 6460
52bb0670 6461#if !defined(PERL_EXTERNAL_GLOB)
72b16652 6462 /* XXX this can be tightened up and made more failsafe. */
f444d496 6463 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
7d3fb230 6464 GV *glob_gv;
72b16652 6465 ENTER;
00ca71c1 6466 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
a0714e2c 6467 newSVpvs("File::Glob"), NULL, NULL, NULL);
5c1737d1
NC		 6468 gv = gv_fetchpvs("CORE::GLOBAL::glob", 0, SVt_PVCV);
6469 glob_gv = gv_fetchpvs("File::Glob::csh_glob", 0, SVt_PVCV);
7d3fb230 6470 GvCV(gv) = GvCV(glob_gv);
b37c2d43 6471 SvREFCNT_inc_void((SV*)GvCV(gv));
7d3fb230 6472 GvIMPORTED_CV_on(gv);
72b16652
GS		 6473 LEAVE;
6474 }
52bb0670 6475#endif /* PERL_EXTERNAL_GLOB */
72b16652 6476
b9f751c0 6477 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
5196be3e 6478 append_elem(OP_GLOB, o,
80252599 6479 newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
1f2bfc8a 6480 o->op_type = OP_LIST;
22c35a8c 6481 o->op_ppaddr = PL_ppaddr[OP_LIST];
1f2bfc8a 6482 cLISTOPo->op_first->op_type = OP_PUSHMARK;
22c35a8c 6483 cLISTOPo->op_first->op_ppaddr = PL_ppaddr[OP_PUSHMARK];
ad33f57d 6484 cLISTOPo->op_first->op_targ = 0;
1f2bfc8a 6485 o = newUNOP(OP_ENTERSUB, OPf_STACKED,
aeea060c 6486 append_elem(OP_LIST, o,
1f2bfc8a
MB		 6487 scalar(newUNOP(OP_RV2CV, 0,
6488 newGVOP(OP_GV, 0, gv)))));
d58bf5aa
MB		 6489 o = newUNOP(OP_NULL, 0, ck_subr(o));
6490 o->op_targ = OP_GLOB; /* hint at what it used to be */
6491 return o;
b1cb66bf 6492 }
6493 gv = newGVgen("main");
a0d0e21e 6494 gv_IOadd(gv);
11343788
MB		 6495 append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
6496 scalarkids(o);
649da076 6497 return o;
79072805
LW		 6498}
6499
6500OP *
cea2e8a9 6501Perl_ck_grep(pTHX_ OP *o)
79072805 6502{
27da23d5 6503 dVAR;
03ca120d 6504 LOGOP *gwop = NULL;
79072805 6505 OP *kid;
6867be6d 6506 const OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
59f00321 6507 I32 offset;
79072805 6508
22c35a8c 6509 o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
03ca120d 6510 /* don't allocate gwop here, as we may leak it if PL_error_count > 0 */
aeea060c 6511
11343788 6512 if (o->op_flags & OPf_STACKED) {
a0d0e21e 6513 OP* k;
11343788
MB		 6514 o = ck_sort(o);
6515 kid = cLISTOPo->op_first->op_sibling;
d09ad856
BS		 6516 if (!cUNOPx(kid)->op_next)
6517 Perl_croak(aTHX_ "panic: ck_grep");
e3c9a8b9 6518 for (k = cUNOPx(kid)->op_first; k; k = k->op_next) {
a0d0e21e
LW		 6519 kid = k;
6520 }
03ca120d 6521 NewOp(1101, gwop, 1, LOGOP);
a0d0e21e 6522 kid->op_next = (OP*)gwop;
11343788 6523 o->op_flags &= ~OPf_STACKED;
93a17b20 6524 }
11343788 6525 kid = cLISTOPo->op_first->op_sibling;
a0d0e21e
LW		 6526 if (type == OP_MAPWHILE)
6527 list(kid);
6528 else
6529 scalar(kid);
11343788 6530 o = ck_fun(o);
3280af22 6531 if (PL_error_count)
11343788 6532 return o;
aeea060c 6533 kid = cLISTOPo->op_first->op_sibling;
79072805 6534 if (kid->op_type != OP_NULL)
cea2e8a9 6535 Perl_croak(aTHX_ "panic: ck_grep");
79072805
LW		 6536 kid = kUNOP->op_first;
6537
03ca120d
MHM		 6538 if (!gwop)
6539 NewOp(1101, gwop, 1, LOGOP);
a0d0e21e 6540 gwop->op_type = type;
22c35a8c 6541 gwop->op_ppaddr = PL_ppaddr[type];
11343788 6542 gwop->op_first = listkids(o);
79072805 6543 gwop->op_flags |= OPf_KIDS;
79072805 6544 gwop->op_other = LINKLIST(kid);
79072805 6545 kid->op_next = (OP*)gwop;
59f00321 6546 offset = pad_findmy("$_");
00b1698f 6547 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
59f00321
RGS		 6548 o->op_private = gwop->op_private = 0;
6549 gwop->op_targ = pad_alloc(type, SVs_PADTMP);
6550 }
6551 else {
6552 o->op_private = gwop->op_private = OPpGREP_LEX;
6553 gwop->op_targ = o->op_targ = offset;
6554 }
79072805 6555
11343788 6556 kid = cLISTOPo->op_first->op_sibling;
a0d0e21e 6557 if (!kid || !kid->op_sibling)
53e06cf0 6558 return too_few_arguments(o,OP_DESC(o));
a0d0e21e
LW		 6559 for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
6560 mod(kid, OP_GREPSTART);
6561
79072805
LW		 6562 return (OP*)gwop;
6563}
6564
6565OP *
cea2e8a9 6566Perl_ck_index(pTHX_ OP *o)
79072805 6567{
11343788
MB		 6568 if (o->op_flags & OPf_KIDS) {
6569 OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
0b71040e
LW		 6570 if (kid)
6571 kid = kid->op_sibling; /* get past "big" */
79072805 6572 if (kid && kid->op_type == OP_CONST)
2779dcf1 6573 fbm_compile(((SVOP*)kid)->op_sv, 0);
79072805 6574 }
11343788 6575 return ck_fun(o);
79072805
LW		 6576}
6577
6578OP *
cea2e8a9 6579Perl_ck_lengthconst(pTHX_ OP *o)
79072805
LW		 6580{
6581 /* XXX length optimization goes here */
11343788 6582 return ck_fun(o);
79072805
LW		 6583}
6584
6585OP *
cea2e8a9 6586Perl_ck_lfun(pTHX_ OP *o)
79072805 6587{
6867be6d 6588 const OPCODE type = o->op_type;
5dc0d613 6589 return modkids(ck_fun(o), type);
79072805
LW		 6590}
6591
6592OP *
cea2e8a9 6593Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */
69794302 6594{
12bcd1a6 6595 if ((o->op_flags & OPf_KIDS) && ckWARN2(WARN_DEPRECATED, WARN_SYNTAX)) {
d0334bed
GS		 6596 switch (cUNOPo->op_first->op_type) {
6597 case OP_RV2AV:
a8739d98
JH		 6598 /* This is needed for
6599 if (defined %stash::)
6600 to work. Do not break Tk.
6601 */
1c846c1f 6602 break; /* Globals via GV can be undef */
d0334bed
GS		 6603 case OP_PADAV:
6604 case OP_AASSIGN: /* Is this a good idea? */
12bcd1a6 6605 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
f10b0346 6606 "defined(@array) is deprecated");
12bcd1a6 6607 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
cc507455 6608 "\t(Maybe you should just omit the defined()?)\n");
69794302 6609 break;
d0334bed 6610 case OP_RV2HV:
a8739d98
JH		 6611 /* This is needed for
6612 if (defined %stash::)
6613 to work. Do not break Tk.
6614 */
1c846c1f 6615 break; /* Globals via GV can be undef */
d0334bed 6616 case OP_PADHV:
12bcd1a6 6617 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
894356b3 6618 "defined(%%hash) is deprecated");
12bcd1a6 6619 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
cc507455 6620 "\t(Maybe you should just omit the defined()?)\n");
d0334bed
GS		 6621 break;
6622 default:
6623 /* no warning */
6624 break;
6625 }
69794302
MJD		 6626 }
6627 return ck_rfun(o);
6628}
6629
6630OP *
cea2e8a9 6631Perl_ck_rfun(pTHX_ OP *o)
8990e307 6632{
6867be6d 6633 const OPCODE type = o->op_type;
5dc0d613 6634 return refkids(ck_fun(o), type);
8990e307
LW		 6635}
6636
6637OP *
cea2e8a9 6638Perl_ck_listiob(pTHX_ OP *o)
79072805
LW		 6639{
6640 register OP *kid;
aeea060c 6641
11343788 6642 kid = cLISTOPo->op_first;
79072805 6643 if (!kid) {
11343788
MB		 6644 o = force_list(o);
6645 kid = cLISTOPo->op_first;
79072805
LW		 6646 }
6647 if (kid->op_type == OP_PUSHMARK)
6648 kid = kid->op_sibling;
11343788 6649 if (kid && o->op_flags & OPf_STACKED)
79072805
LW		 6650 kid = kid->op_sibling;
6651 else if (kid && !kid->op_sibling) { /* print HANDLE; */
6652 if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
11343788 6653 o->op_flags |= OPf_STACKED; /* make it a filehandle */
748a9306 6654 kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
11343788
MB		 6655 cLISTOPo->op_first->op_sibling = kid;
6656 cLISTOPo->op_last = kid;
79072805
LW		 6657 kid = kid->op_sibling;
6658 }
6659 }
b2ffa427 6660
79072805 6661 if (!kid)
54b9620d 6662 append_elem(o->op_type, o, newDEFSVOP());
79072805 6663
2de3dbcc 6664 return listkids(o);
bbce6d69 6665}
6666
6667OP *
0d863452
RH		 6668Perl_ck_say(pTHX_ OP *o)
6669{
6670 o = ck_listiob(o);
6671 o->op_type = OP_PRINT;
6672 cLISTOPo->op_last = cLISTOPo->op_last->op_sibling
396482e1 6673 = newSVOP(OP_CONST, 0, newSVpvs("\n"));
0d863452
RH		 6674 return o;
6675}
6676
6677OP *
6678Perl_ck_smartmatch(pTHX_ OP *o)
6679{
97aff369 6680 dVAR;
0d863452
RH		 6681 if (0 == (o->op_flags & OPf_SPECIAL)) {
6682 OP *first = cBINOPo->op_first;
6683 OP *second = first->op_sibling;
6684
6685 /* Implicitly take a reference to an array or hash */
5f66b61c 6686 first->op_sibling = NULL;
0d863452
RH		 6687 first = cBINOPo->op_first = ref_array_or_hash(first);
6688 second = first->op_sibling = ref_array_or_hash(second);
6689
6690 /* Implicitly take a reference to a regular expression */
6691 if (first->op_type == OP_MATCH) {
6692 first->op_type = OP_QR;
6693 first->op_ppaddr = PL_ppaddr[OP_QR];
6694 }
6695 if (second->op_type == OP_MATCH) {
6696 second->op_type = OP_QR;
6697 second->op_ppaddr = PL_ppaddr[OP_QR];
6698 }
6699 }
6700
6701 return o;
6702}
6703
6704
6705OP *
b162f9ea
IZ		 6706Perl_ck_sassign(pTHX_ OP *o)
6707{
6708 OP *kid = cLISTOPo->op_first;
6709 /* has a disposable target? */
6710 if ((PL_opargs[kid->op_type] & OA_TARGLEX)
6b66af17
GS		 6711 && !(kid->op_flags & OPf_STACKED)
6712 /* Cannot steal the second time! */
6713 && !(kid->op_private & OPpTARGET_MY))
b162f9ea 6714 {
551405c4 6715 OP * const kkid = kid->op_sibling;
b162f9ea
IZ		 6716
6717 /* Can just relocate the target. */
2c2d71f5
JH		 6718 if (kkid && kkid->op_type == OP_PADSV
6719 && !(kkid->op_private & OPpLVAL_INTRO))
6720 {
b162f9ea 6721 kid->op_targ = kkid->op_targ;
743e66e6 6722 kkid->op_targ = 0;
b162f9ea
IZ		 6723 /* Now we do not need PADSV and SASSIGN. */
6724 kid->op_sibling = o->op_sibling; /* NULL */
6725 cLISTOPo->op_first = NULL;
eb8433b7
NC		 6726#ifdef PERL_MAD
6727 op_getmad(o,kid,'O');
6728 op_getmad(kkid,kid,'M');
6729#else
b162f9ea
IZ		 6730 op_free(o);
6731 op_free(kkid);
eb8433b7 6732#endif
b162f9ea
IZ		 6733 kid->op_private |= OPpTARGET_MY; /* Used for context settings */
6734 return kid;
6735 }
6736 }
6737 return o;
6738}
6739
6740OP *
cea2e8a9 6741Perl_ck_match(pTHX_ OP *o)
79072805 6742{
97aff369 6743 dVAR;
0d863452 6744 if (o->op_type != OP_QR && PL_compcv) {
6867be6d 6745 const I32 offset = pad_findmy("$_");
00b1698f 6746 if (offset != NOT_IN_PAD && !(PAD_COMPNAME_FLAGS_isOUR(offset))) {
59f00321
RGS		 6747 o->op_targ = offset;
6748 o->op_private |= OPpTARGET_MY;
6749 }
6750 }
6751 if (o->op_type == OP_MATCH || o->op_type == OP_QR)
6752 o->op_private |= OPpRUNTIME;
11343788 6753 return o;
79072805
LW		 6754}
6755
6756OP *
f5d5a27c
CS		 6757Perl_ck_method(pTHX_ OP *o)
6758{
551405c4 6759 OP * const kid = cUNOPo->op_first;
f5d5a27c
CS		 6760 if (kid->op_type == OP_CONST) {
6761 SV* sv = kSVOP->op_sv;
a4fc7abc
AL		 6762 const char * const method = SvPVX_const(sv);
6763 if (!(strchr(method, ':') || strchr(method, '\''))) {
f5d5a27c 6764 OP *cmop;
1c846c1f 6765 if (!SvREADONLY(sv) || !SvFAKE(sv)) {
a4fc7abc 6766 sv = newSVpvn_share(method, SvCUR(sv), 0);
1c846c1f
NIS		 6767 }
6768 else {
a0714e2c 6769 kSVOP->op_sv = NULL;
1c846c1f 6770 }
f5d5a27c 6771 cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
eb8433b7
NC		 6772#ifdef PERL_MAD
6773 op_getmad(o,cmop,'O');
6774#else
f5d5a27c 6775 op_free(o);
eb8433b7 6776#endif
f5d5a27c
CS		 6777 return cmop;
6778 }
6779 }
6780 return o;
6781}
6782
6783OP *
cea2e8a9 6784Perl_ck_null(pTHX_ OP *o)
79072805 6785{
96a5add6 6786 PERL_UNUSED_CONTEXT;
11343788 6787 return o;
79072805
LW		 6788}
6789
6790OP *
16fe6d59
GS		 6791Perl_ck_open(pTHX_ OP *o)
6792{
97aff369 6793 dVAR;
551405c4 6794 HV * const table = GvHV(PL_hintgv);
16fe6d59 6795 if (table) {
a4fc7abc 6796 SV **svp = hv_fetchs(table, "open_IN", FALSE);
16fe6d59 6797 if (svp && *svp) {
551405c4 6798 const I32 mode = mode_from_discipline(*svp);
16fe6d59
GS		 6799 if (mode & O_BINARY)
6800 o->op_private |= OPpOPEN_IN_RAW;
6801 else if (mode & O_TEXT)
6802 o->op_private |= OPpOPEN_IN_CRLF;
6803 }
6804
a4fc7abc 6805 svp = hv_fetchs(table, "open_OUT", FALSE);
16fe6d59 6806 if (svp && *svp) {
551405c4 6807 const I32 mode = mode_from_discipline(*svp);
16fe6d59
GS		 6808 if (mode & O_BINARY)
6809 o->op_private |= OPpOPEN_OUT_RAW;
6810 else if (mode & O_TEXT)
6811 o->op_private |= OPpOPEN_OUT_CRLF;
6812 }
6813 }
6814 if (o->op_type == OP_BACKTICK)
6815 return o;
3b82e551
JH		 6816 {
6817 /* In case of three-arg dup open remove strictness
6818 * from the last arg if it is a bareword. */
551405c4
AL		 6819 OP * const first = cLISTOPx(o)->op_first; /* The pushmark. */
6820 OP * const last = cLISTOPx(o)->op_last; /* The bareword. */
3b82e551 6821 OP *oa;
b15aece3 6822 const char *mode;
3b82e551
JH		 6823
6824 if ((last->op_type == OP_CONST) && /* The bareword. */
6825 (last->op_private & OPpCONST_BARE) &&
6826 (last->op_private & OPpCONST_STRICT) &&
6827 (oa = first->op_sibling) && /* The fh. */
6828 (oa = oa->op_sibling) && /* The mode. */
ea1d064a 6829 (oa->op_type == OP_CONST) &&
3b82e551 6830 SvPOK(((SVOP*)oa)->op_sv) &&
b15aece3 6831 (mode = SvPVX_const(((SVOP*)oa)->op_sv)) &&
3b82e551
JH		 6832 mode[0] == '>' && mode[1] == '&' && /* A dup open. */
6833 (last == oa->op_sibling)) /* The bareword. */
6834 last->op_private &= ~OPpCONST_STRICT;
6835 }
16fe6d59
GS		 6836 return ck_fun(o);
6837}
6838
6839OP *
cea2e8a9 6840Perl_ck_repeat(pTHX_ OP *o)
79072805 6841{
11343788
MB		 6842 if (cBINOPo->op_first->op_flags & OPf_PARENS) {
6843 o->op_private |= OPpREPEAT_DOLIST;
6844 cBINOPo->op_first = force_list(cBINOPo->op_first);
79072805
LW		 6845 }
6846 else
11343788
MB		 6847 scalar(o);
6848 return o;
79072805
LW		 6849}
6850
6851OP *
cea2e8a9 6852Perl_ck_require(pTHX_ OP *o)
8990e307 6853{
97aff369 6854 dVAR;
a0714e2c 6855 GV* gv = NULL;
ec4ab249 6856
11343788 6857 if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
551405c4 6858 SVOP * const kid = (SVOP*)cUNOPo->op_first;
8990e307
LW		 6859
6860 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
551405c4 6861 SV * const sv = kid->op_sv;
5c144d81 6862 U32 was_readonly = SvREADONLY(sv);
8990e307 6863 char *s;
5c144d81
NC		 6864
6865 if (was_readonly) {
6866 if (SvFAKE(sv)) {
6867 sv_force_normal_flags(sv, 0);
6868 assert(!SvREADONLY(sv));
6869 was_readonly = 0;
6870 } else {
6871 SvREADONLY_off(sv);
6872 }
6873 }
6874
6875 for (s = SvPVX(sv); *s; s++) {
a0d0e21e 6876 if (*s == ':' && s[1] == ':') {
42d9b98d 6877 const STRLEN len = strlen(s+2)+1;
a0d0e21e 6878 *s = '/';
42d9b98d 6879 Move(s+2, s+1, len, char);
5c144d81 6880 SvCUR_set(sv, SvCUR(sv) - 1);
a0d0e21e 6881 }
8990e307 6882 }
396482e1 6883 sv_catpvs(sv, ".pm");
5c144d81 6884 SvFLAGS(sv) |= was_readonly;
8990e307
LW		 6885 }
6886 }
ec4ab249 6887
a72a1c8b
RGS		 6888 if (!(o->op_flags & OPf_SPECIAL)) { /* Wasn't written as CORE::require */
6889 /* handle override, if any */
fafc274c 6890 gv = gv_fetchpvs("require", GV_NOTQUAL, SVt_PVCV);
d6a985f2 6891 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
a4fc7abc 6892 GV * const * const gvp = (GV**)hv_fetchs(PL_globalstash, "require", FALSE);
a0714e2c 6893 gv = gvp ? *gvp : NULL;
d6a985f2 6894 }
a72a1c8b 6895 }
ec4ab249 6896
b9f751c0 6897 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
551405c4 6898 OP * const kid = cUNOPo->op_first;
f11453cb
NC		 6899 OP * newop;
6900
ec4ab249 6901 cUNOPo->op_first = 0;
f11453cb 6902#ifndef PERL_MAD
ec4ab249 6903 op_free(o);
eb8433b7 6904#endif
f11453cb
NC		 6905 newop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
6906 append_elem(OP_LIST, kid,
6907 scalar(newUNOP(OP_RV2CV, 0,
6908 newGVOP(OP_GV, 0,
6909 gv))))));
6910 op_getmad(o,newop,'O');
eb8433b7 6911 return newop;
ec4ab249
GA		 6912 }
6913
11343788 6914 return ck_fun(o);
8990e307
LW		 6915}
6916
78f9721b
SM		 6917OP *
6918Perl_ck_return(pTHX_ OP *o)
6919{
97aff369 6920 dVAR;
78f9721b 6921 if (CvLVALUE(PL_compcv)) {
6867be6d 6922 OP *kid;
78f9721b
SM		 6923 for (kid = cLISTOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
6924 mod(kid, OP_LEAVESUBLV);
6925 }
6926 return o;
6927}
6928
79072805 6929OP *
cea2e8a9 6930Perl_ck_select(pTHX_ OP *o)
79072805 6931{
27da23d5 6932 dVAR;
c07a80fd 6933 OP* kid;
11343788
MB		 6934 if (o->op_flags & OPf_KIDS) {
6935 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
2304df62 6936 if (kid && kid->op_sibling) {
11343788 6937 o->op_type = OP_SSELECT;
22c35a8c 6938 o->op_ppaddr = PL_ppaddr[OP_SSELECT];
11343788
MB		 6939 o = ck_fun(o);
6940 return fold_constants(o);
79072805
LW		 6941 }
6942 }
11343788
MB		 6943 o = ck_fun(o);
6944 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
c07a80fd 6945 if (kid && kid->op_type == OP_RV2GV)
6946 kid->op_private &= ~HINT_STRICT_REFS;
11343788 6947 return o;
79072805
LW		 6948}
6949
6950OP *
cea2e8a9 6951Perl_ck_shift(pTHX_ OP *o)
79072805 6952{
97aff369 6953 dVAR;
6867be6d 6954 const I32 type = o->op_type;
79072805 6955
11343788 6956 if (!(o->op_flags & OPf_KIDS)) {
6d4ff0d2 6957 OP *argop;
eb8433b7
NC		 6958 /* FIXME - this can be refactored to reduce code in #ifdefs */
6959#ifdef PERL_MAD
1d866c12 6960 OP * const oldo = o;
eb8433b7 6961#else
11343788 6962 op_free(o);
eb8433b7 6963#endif
6d4ff0d2 6964 argop = newUNOP(OP_RV2AV, 0,
8fde6460 6965 scalar(newGVOP(OP_GV, 0, CvUNIQUE(PL_compcv) ? PL_argvgv : PL_defgv)));
eb8433b7
NC		 6966#ifdef PERL_MAD
6967 o = newUNOP(type, 0, scalar(argop));
6968 op_getmad(oldo,o,'O');
6969 return o;
6970#else
6d4ff0d2 6971 return newUNOP(type, 0, scalar(argop));
eb8433b7 6972#endif
79072805 6973 }
11343788 6974 return scalar(modkids(ck_fun(o), type));
79072805
LW		 6975}
6976
6977OP *
cea2e8a9 6978Perl_ck_sort(pTHX_ OP *o)
79072805 6979{
97aff369 6980 dVAR;
8e3f9bdf 6981 OP *firstkid;
bbce6d69 6982
7b9ef140
RH		 6983 if (o->op_type == OP_SORT && (PL_hints & HINT_LOCALIZE_HH) != 0)
6984 {
a4fc7abc 6985 HV * const hinthv = GvHV(PL_hintgv);
7b9ef140 6986 if (hinthv) {
a4fc7abc 6987 SV ** const svp = hv_fetchs(hinthv, "sort", FALSE);
7b9ef140 6988 if (svp) {
a4fc7abc 6989 const I32 sorthints = (I32)SvIV(*svp);
7b9ef140
RH		 6990 if ((sorthints & HINT_SORT_QUICKSORT) != 0)
6991 o->op_private |= OPpSORT_QSORT;
6992 if ((sorthints & HINT_SORT_STABLE) != 0)
6993 o->op_private |= OPpSORT_STABLE;
6994 }
6995 }
6996 }
6997
9ea6e965 6998 if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
51a19bc0 6999 simplify_sort(o);
8e3f9bdf
GS		 7000 firstkid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
7001 if (o->op_flags & OPf_STACKED) { /* may have been cleared */
9c5ffd7c 7002 OP *k = NULL;
8e3f9bdf 7003 OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
79072805 7004
463ee0b2 7005 if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
79072805 7006 linklist(kid);
463ee0b2
LW		 7007 if (kid->op_type == OP_SCOPE) {
7008 k = kid->op_next;
7009 kid->op_next = 0;
79072805 7010 }
463ee0b2 7011 else if (kid->op_type == OP_LEAVE) {
11343788 7012 if (o->op_type == OP_SORT) {
93c66552 7013 op_null(kid); /* wipe out leave */
748a9306 7014 kid->op_next = kid;
463ee0b2 7015
748a9306
LW		 7016 for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
7017 if (k->op_next == kid)
7018 k->op_next = 0;
71a29c3c
GS		 7019 /* don't descend into loops */
7020 else if (k->op_type == OP_ENTERLOOP
7021 || k->op_type == OP_ENTERITER)
7022 {
7023 k = cLOOPx(k)->op_lastop;
7024 }
748a9306 7025 }
463ee0b2 7026 }
748a9306
LW		 7027 else
7028 kid->op_next = 0; /* just disconnect the leave */
a0d0e21e 7029 k = kLISTOP->op_first;
463ee0b2 7030 }
a2efc822 7031 CALL_PEEP(k);
a0d0e21e 7032
8e3f9bdf
GS		 7033 kid = firstkid;
7034 if (o->op_type == OP_SORT) {
7035 /* provide scalar context for comparison function/block */
7036 kid = scalar(kid);
a0d0e21e 7037 kid->op_next = kid;
8e3f9bdf 7038 }
a0d0e21e
LW		 7039 else
7040 kid->op_next = k;
11343788 7041 o->op_flags |= OPf_SPECIAL;
79072805 7042 }
c6e96bcb 7043 else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV)
93c66552 7044 op_null(firstkid);
8e3f9bdf
GS		 7045
7046 firstkid = firstkid->op_sibling;
79072805 7047 }
bbce6d69 7048
8e3f9bdf
GS		 7049 /* provide list context for arguments */
7050 if (o->op_type == OP_SORT)
7051 list(firstkid);
7052
11343788 7053 return o;
79072805 7054}
bda4119b
GS		 7055
7056STATIC void
cea2e8a9 7057S_simplify_sort(pTHX_ OP *o)
9c007264 7058{
97aff369 7059 dVAR;
9c007264
JH		 7060 register OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
7061 OP *k;
eb209983 7062 int descending;
350de78d 7063 GV *gv;
770526c1 7064 const char *gvname;
9c007264
JH		 7065 if (!(o->op_flags & OPf_STACKED))
7066 return;
fafc274c
NC		 7067 GvMULTI_on(gv_fetchpvs("a", GV_ADD|GV_NOTQUAL, SVt_PV));
7068 GvMULTI_on(gv_fetchpvs("b", GV_ADD|GV_NOTQUAL, SVt_PV));
82092f1d 7069 kid = kUNOP->op_first; /* get past null */
9c007264
JH		 7070 if (kid->op_type != OP_SCOPE)
7071 return;
7072 kid = kLISTOP->op_last; /* get past scope */
7073 switch(kid->op_type) {
7074 case OP_NCMP:
7075 case OP_I_NCMP:
7076 case OP_SCMP:
7077 break;
7078 default:
7079 return;
7080 }
7081 k = kid; /* remember this node*/
7082 if (kBINOP->op_first->op_type != OP_RV2SV)
7083 return;
7084 kid = kBINOP->op_first; /* get past cmp */
7085 if (kUNOP->op_first->op_type != OP_GV)
7086 return;
7087 kid = kUNOP->op_first; /* get past rv2sv */
638eceb6 7088 gv = kGVOP_gv;
350de78d 7089 if (GvSTASH(gv) != PL_curstash)
9c007264 7090 return;
770526c1
NC		 7091 gvname = GvNAME(gv);
7092 if (*gvname == 'a' && gvname[1] == '\0')
eb209983 7093 descending = 0;
770526c1 7094 else if (*gvname == 'b' && gvname[1] == '\0')
eb209983 7095 descending = 1;
9c007264
JH		 7096 else
7097 return;
eb209983 7098
9c007264
JH		 7099 kid = k; /* back to cmp */
7100 if (kBINOP->op_last->op_type != OP_RV2SV)
7101 return;
7102 kid = kBINOP->op_last; /* down to 2nd arg */
7103 if (kUNOP->op_first->op_type != OP_GV)
7104 return;
7105 kid = kUNOP->op_first; /* get past rv2sv */
638eceb6 7106 gv = kGVOP_gv;
770526c1
NC		 7107 if (GvSTASH(gv) != PL_curstash)
7108 return;
7109 gvname = GvNAME(gv);
7110 if ( descending
7111 ? !(*gvname == 'a' && gvname[1] == '\0')
7112 : !(*gvname == 'b' && gvname[1] == '\0'))
9c007264
JH		 7113 return;
7114 o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
eb209983
NC		 7115 if (descending)
7116 o->op_private |= OPpSORT_DESCEND;
9c007264
JH		 7117 if (k->op_type == OP_NCMP)
7118 o->op_private |= OPpSORT_NUMERIC;
7119 if (k->op_type == OP_I_NCMP)
7120 o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
e507f050
SM		 7121 kid = cLISTOPo->op_first->op_sibling;
7122 cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
eb8433b7
NC		 7123#ifdef PERL_MAD
7124 op_getmad(kid,o,'S'); /* then delete it */
7125#else
e507f050 7126 op_free(kid); /* then delete it */
eb8433b7 7127#endif
9c007264 7128}
79072805
LW		 7129
7130OP *
cea2e8a9 7131Perl_ck_split(pTHX_ OP *o)
79072805 7132{
27da23d5 7133 dVAR;
79072805 7134 register OP *kid;
aeea060c 7135
11343788
MB		 7136 if (o->op_flags & OPf_STACKED)
7137 return no_fh_allowed(o);
79072805 7138
11343788 7139 kid = cLISTOPo->op_first;
8990e307 7140 if (kid->op_type != OP_NULL)
cea2e8a9 7141 Perl_croak(aTHX_ "panic: ck_split");
8990e307 7142 kid = kid->op_sibling;
11343788
MB		 7143 op_free(cLISTOPo->op_first);
7144 cLISTOPo->op_first = kid;
85e6fe83 7145 if (!kid) {
396482e1 7146 cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvs(" "));
11343788 7147 cLISTOPo->op_last = kid; /* There was only one element previously */
85e6fe83 7148 }
79072805 7149
de4bf5b3 7150 if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
551405c4 7151 OP * const sibl = kid->op_sibling;
463ee0b2 7152 kid->op_sibling = 0;
131b3ad0 7153 kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, 0);
11343788
MB		 7154 if (cLISTOPo->op_first == cLISTOPo->op_last)
7155 cLISTOPo->op_last = kid;
7156 cLISTOPo->op_first = kid;
79072805
LW		 7157 kid->op_sibling = sibl;
7158 }
7159
7160 kid->op_type = OP_PUSHRE;
22c35a8c 7161 kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
79072805 7162 scalar(kid);
041457d9 7163 if (((PMOP *)kid)->op_pmflags & PMf_GLOBAL && ckWARN(WARN_REGEXP)) {
f34840d8
MJD		 7164 Perl_warner(aTHX_ packWARN(WARN_REGEXP),
7165 "Use of /g modifier is meaningless in split");
7166 }
79072805
LW		 7167
7168 if (!kid->op_sibling)
54b9620d 7169 append_elem(OP_SPLIT, o, newDEFSVOP());
79072805
LW		 7170
7171 kid = kid->op_sibling;
7172 scalar(kid);
7173
7174 if (!kid->op_sibling)
11343788 7175 append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
79072805
LW		 7176
7177 kid = kid->op_sibling;
7178 scalar(kid);
7179
7180 if (kid->op_sibling)
53e06cf0 7181 return too_many_arguments(o,OP_DESC(o));
79072805 7182
11343788 7183 return o;
79072805
LW		 7184}
7185
7186OP *
1c846c1f 7187Perl_ck_join(pTHX_ OP *o)
eb6e2d6f 7188{
551405c4 7189 const OP * const kid = cLISTOPo->op_first->op_sibling;
041457d9
DM		 7190 if (kid && kid->op_type == OP_MATCH) {
7191 if (ckWARN(WARN_SYNTAX)) {
6867be6d
AL		 7192 const REGEXP *re = PM_GETRE(kPMOP);
7193 const char *pmstr = re ? re->precomp : "STRING";
9014280d 7194 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
eb6e2d6f
GS		 7195 "/%s/ should probably be written as \"%s\"",
7196 pmstr, pmstr);
7197 }
7198 }
7199 return ck_fun(o);
7200}
7201
7202OP *
cea2e8a9 7203Perl_ck_subr(pTHX_ OP *o)
79072805 7204{
97aff369 7205 dVAR;
11343788
MB		 7206 OP *prev = ((cUNOPo->op_first->op_sibling)
7207 ? cUNOPo : ((UNOP*)cUNOPo->op_first))->op_first;
7208 OP *o2 = prev->op_sibling;
4633a7c4 7209 OP *cvop;
c445ea15
AL		 7210 char *proto = NULL;
7211 CV *cv = NULL;
7212 GV *namegv = NULL;
4633a7c4
LW		 7213 int optional = 0;
7214 I32 arg = 0;
5b794e05 7215 I32 contextclass = 0;
c445ea15 7216 char *e = NULL;
0723351e 7217 bool delete_op = 0;
4633a7c4 7218
d3011074 7219 o->op_private |= OPpENTERSUB_HASTARG;
11343788 7220 for (cvop = o2; cvop->op_sibling; cvop = cvop->op_sibling) ;
4633a7c4
LW		 7221 if (cvop->op_type == OP_RV2CV) {
7222 SVOP* tmpop;
11343788 7223 o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
93c66552 7224 op_null(cvop); /* disable rv2cv */
4633a7c4 7225 tmpop = (SVOP*)((UNOP*)cvop)->op_first;
76cd736e 7226 if (tmpop->op_type == OP_GV && !(o->op_private & OPpENTERSUB_AMPER)) {
638eceb6 7227 GV *gv = cGVOPx_gv(tmpop);
350de78d 7228 cv = GvCVu(gv);
76cd736e
GS		 7229 if (!cv)
7230 tmpop->op_private |= OPpEARLY_CV;
06492da6
SF		 7231 else {
7232 if (SvPOK(cv)) {
7233 namegv = CvANON(cv) ? gv : CvGV(cv);
8b6b16e7 7234 proto = SvPV_nolen((SV*)cv);
06492da6
SF		 7235 }
7236 if (CvASSERTION(cv)) {
7237 if (PL_hints & HINT_ASSERTING) {
7238 if (PERLDB_ASSERTION && PL_curstash != PL_debstash)
7239 o->op_private |= OPpENTERSUB_DB;
7240 }
8fa7688f 7241 else {
0723351e 7242 delete_op = 1;
041457d9 7243 if (!(PL_hints & HINT_ASSERTIONSSEEN) && ckWARN(WARN_ASSERTIONS)) {
8fa7688f
SF		 7244 Perl_warner(aTHX_ packWARN(WARN_ASSERTIONS),
7245 "Impossible to activate assertion call");
7246 }
7247 }
06492da6 7248 }
46fc3d4c 7249 }
4633a7c4
LW		 7250 }
7251 }
f5d5a27c 7252 else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
7a52d87a
GS		 7253 if (o2->op_type == OP_CONST)
7254 o2->op_private &= ~OPpCONST_STRICT;
58a40671 7255 else if (o2->op_type == OP_LIST) {
5f66b61c
AL		 7256 OP * const sib = ((UNOP*)o2)->op_first->op_sibling;
7257 if (sib && sib->op_type == OP_CONST)
7258 sib->op_private &= ~OPpCONST_STRICT;
58a40671 7259 }
7a52d87a 7260 }
3280af22
NIS		 7261 o->op_private |= (PL_hints & HINT_STRICT_REFS);
7262 if (PERLDB_SUB && PL_curstash != PL_debstash)
11343788
MB		 7263 o->op_private |= OPpENTERSUB_DB;
7264 while (o2 != cvop) {
eb8433b7
NC		 7265 OP* o3;
7266 if (PL_madskills && o2->op_type == OP_NULL)
7267 o3 = ((UNOP*)o2)->op_first;
7268 else
7269 o3 = o2;
4633a7c4
LW		 7270 if (proto) {
7271 switch (*proto) {
7272 case '\0':
5dc0d613 7273 return too_many_arguments(o, gv_ename(namegv));
4633a7c4
LW		 7274 case ';':
7275 optional = 1;
7276 proto++;
7277 continue;
7278 case '$':
7279 proto++;
7280 arg++;
11343788 7281 scalar(o2);
4633a7c4
LW		 7282 break;
7283 case '%':
7284 case '@':
11343788 7285 list(o2);
4633a7c4
LW		 7286 arg++;
7287 break;
7288 case '&':
7289 proto++;
7290 arg++;
eb8433b7 7291 if (o3->op_type != OP_REFGEN && o3->op_type != OP_UNDEF)
75fc29ea
GS		 7292 bad_type(arg,
7293 arg == 1 ? "block or sub {}" : "sub {}",
eb8433b7 7294 gv_ename(namegv), o3);
4633a7c4
LW		 7295 break;
7296 case '*':
2ba6ecf4 7297 /* '*' allows any scalar type, including bareword */
4633a7c4
LW		 7298 proto++;
7299 arg++;
eb8433b7 7300 if (o3->op_type == OP_RV2GV)
2ba6ecf4 7301 goto wrapref; /* autoconvert GLOB -> GLOBref */
eb8433b7
NC		 7302 else if (o3->op_type == OP_CONST)
7303 o3->op_private &= ~OPpCONST_STRICT;
7304 else if (o3->op_type == OP_ENTERSUB) {
9675f7ac 7305 /* accidental subroutine, revert to bareword */
eb8433b7 7306 OP *gvop = ((UNOP*)o3)->op_first;
9675f7ac
GS		 7307 if (gvop && gvop->op_type == OP_NULL) {
7308 gvop = ((UNOP*)gvop)->op_first;
7309 if (gvop) {
7310 for (; gvop->op_sibling; gvop = gvop->op_sibling)
7311 ;
7312 if (gvop &&
7313 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
7314 (gvop = ((UNOP*)gvop)->op_first) &&
7315 gvop->op_type == OP_GV)
7316 {
551405c4
AL		 7317 GV * const gv = cGVOPx_gv(gvop);
7318 OP * const sibling = o2->op_sibling;
396482e1 7319 SV * const n = newSVpvs("");
eb8433b7 7320#ifdef PERL_MAD
1d866c12 7321 OP * const oldo2 = o2;
eb8433b7 7322#else
9675f7ac 7323 op_free(o2);
eb8433b7 7324#endif
2a797ae2 7325 gv_fullname4(n, gv, "", FALSE);
2692f720 7326 o2 = newSVOP(OP_CONST, 0, n);
eb8433b7 7327 op_getmad(oldo2,o2,'O');
9675f7ac
GS		 7328 prev->op_sibling = o2;
7329 o2->op_sibling = sibling;
7330 }
7331 }
7332 }
7333 }
2ba6ecf4
GS		 7334 scalar(o2);
7335 break;
5b794e05
JH		 7336 case '[': case ']':
7337 goto oops;
7338 break;
4633a7c4
LW		 7339 case '\\':
7340 proto++;
7341 arg++;
5b794e05 7342 again:
4633a7c4 7343 switch (*proto++) {
5b794e05
JH		 7344 case '[':
7345 if (contextclass++ == 0) {
841d93c8 7346 e = strchr(proto, ']');
5b794e05
JH		 7347 if (!e || e == proto)
7348 goto oops;
7349 }
7350 else
7351 goto oops;
7352 goto again;
7353 break;
7354 case ']':
466bafcd 7355 if (contextclass) {
0bd48802 7356 /* XXX We shouldn't be modifying proto, so we can const proto */
6867be6d
AL		 7357 char *p = proto;
7358 const char s = *p;
466bafcd
RGS		 7359 contextclass = 0;
7360 *p = '\0';
7361 while (*--p != '[');
1eb1540c 7362 bad_type(arg, Perl_form(aTHX_ "one of %s", p),
eb8433b7 7363 gv_ename(namegv), o3);
466bafcd
RGS		 7364 *proto = s;
7365 } else
5b794e05
JH		 7366 goto oops;
7367 break;
4633a7c4 7368 case '*':
eb8433b7 7369 if (o3->op_type == OP_RV2GV)
5b794e05
JH		 7370 goto wrapref;
7371 if (!contextclass)
eb8433b7 7372 bad_type(arg, "symbol", gv_ename(namegv), o3);
5b794e05 7373 break;
4633a7c4 7374 case '&':
eb8433b7 7375 if (o3->op_type == OP_ENTERSUB)
5b794e05
JH		 7376 goto wrapref;
7377 if (!contextclass)
eb8433b7
NC		 7378 bad_type(arg, "subroutine entry", gv_ename(namegv),
7379 o3);
5b794e05 7380 break;
4633a7c4 7381 case '$':
eb8433b7
NC		 7382 if (o3->op_type == OP_RV2SV ||
7383 o3->op_type == OP_PADSV ||
7384 o3->op_type == OP_HELEM ||
7385 o3->op_type == OP_AELEM ||
7386 o3->op_type == OP_THREADSV)
5b794e05
JH		 7387 goto wrapref;
7388 if (!contextclass)
eb8433b7 7389 bad_type(arg, "scalar", gv_ename(namegv), o3);
5b794e05 7390 break;
4633a7c4 7391 case '@':
eb8433b7
NC		 7392 if (o3->op_type == OP_RV2AV ||
7393 o3->op_type == OP_PADAV)
5b794e05
JH		 7394 goto wrapref;
7395 if (!contextclass)
eb8433b7 7396 bad_type(arg, "array", gv_ename(namegv), o3);
5b794e05 7397 break;
4633a7c4 7398 case '%':
eb8433b7
NC		 7399 if (o3->op_type == OP_RV2HV ||
7400 o3->op_type == OP_PADHV)
5b794e05
JH		 7401 goto wrapref;
7402 if (!contextclass)
eb8433b7 7403 bad_type(arg, "hash", gv_ename(namegv), o3);
5b794e05
JH		 7404 break;
7405 wrapref:
4633a7c4 7406 {
551405c4
AL		 7407 OP* const kid = o2;
7408 OP* const sib = kid->op_sibling;
4633a7c4 7409 kid->op_sibling = 0;
6fa846a0
GS		 7410 o2 = newUNOP(OP_REFGEN, 0, kid);
7411 o2->op_sibling = sib;
e858de61 7412 prev->op_sibling = o2;
4633a7c4 7413 }
841d93c8 7414 if (contextclass && e) {
5b794e05
JH		 7415 proto = e + 1;
7416 contextclass = 0;
7417 }
4633a7c4
LW		 7418 break;
7419 default: goto oops;
7420 }
5b794e05
JH		 7421 if (contextclass)
7422 goto again;
4633a7c4 7423 break;
b1cb66bf 7424 case ' ':
7425 proto++;
7426 continue;
4633a7c4
LW		 7427 default:
7428 oops:
35c1215d
NC		 7429 Perl_croak(aTHX_ "Malformed prototype for %s: %"SVf,
7430 gv_ename(namegv), cv);
4633a7c4
LW		 7431 }
7432 }
7433 else
11343788
MB		 7434 list(o2);
7435 mod(o2, OP_ENTERSUB);
7436 prev = o2;
7437 o2 = o2->op_sibling;
551405c4 7438 } /* while */
fb73857a 7439 if (proto && !optional &&
7440 (*proto && *proto != '@' && *proto != '%' && *proto != ';'))
5dc0d613 7441 return too_few_arguments(o, gv_ename(namegv));
0723351e 7442 if(delete_op) {
eb8433b7 7443#ifdef PERL_MAD
1d866c12 7444 OP * const oldo = o;
eb8433b7 7445#else
06492da6 7446 op_free(o);
eb8433b7 7447#endif
06492da6 7448 o=newSVOP(OP_CONST, 0, newSViv(0));
eb8433b7 7449 op_getmad(oldo,o,'O');
06492da6 7450 }
11343788 7451 return o;
79072805
LW		 7452}
7453
7454OP *
cea2e8a9 7455Perl_ck_svconst(pTHX_ OP *o)
8990e307 7456{
96a5add6 7457 PERL_UNUSED_CONTEXT;
11343788
MB		 7458 SvREADONLY_on(cSVOPo->op_sv);
7459 return o;
8990e307
LW		 7460}
7461
7462OP *
d4ac975e
GA		 7463Perl_ck_chdir(pTHX_ OP *o)
7464{
7465 if (o->op_flags & OPf_KIDS) {
7466 SVOP *kid = (SVOP*)cUNOPo->op_first;
7467
7468 if (kid && kid->op_type == OP_CONST &&
7469 (kid->op_private & OPpCONST_BARE))
7470 {
7471 o->op_flags |= OPf_SPECIAL;
7472 kid->op_private &= ~OPpCONST_STRICT;
7473 }
7474 }
7475 return ck_fun(o);
7476}
7477
7478OP *
cea2e8a9 7479Perl_ck_trunc(pTHX_ OP *o)
79072805 7480{
11343788
MB		 7481 if (o->op_flags & OPf_KIDS) {
7482 SVOP *kid = (SVOP*)cUNOPo->op_first;
79072805 7483
a0d0e21e
LW		 7484 if (kid->op_type == OP_NULL)
7485 kid = (SVOP*)kid->op_sibling;
bb53490d
GS		 7486 if (kid && kid->op_type == OP_CONST &&
7487 (kid->op_private & OPpCONST_BARE))
7488 {
11343788 7489 o->op_flags |= OPf_SPECIAL;
bb53490d
GS		 7490 kid->op_private &= ~OPpCONST_STRICT;
7491 }
79072805 7492 }
11343788 7493 return ck_fun(o);
79072805
LW		 7494}
7495
35fba0d9 7496OP *
bab9c0ac
RGS		 7497Perl_ck_unpack(pTHX_ OP *o)
7498{
7499 OP *kid = cLISTOPo->op_first;
7500 if (kid->op_sibling) {
7501 kid = kid->op_sibling;
7502 if (!kid->op_sibling)
7503 kid->op_sibling = newDEFSVOP();
7504 }
7505 return ck_fun(o);
7506}
7507
7508OP *
35fba0d9
RG		 7509Perl_ck_substr(pTHX_ OP *o)
7510{
7511 o = ck_fun(o);
1d866c12 7512 if ((o->op_flags & OPf_KIDS) && (o->op_private == 4)) {
35fba0d9
RG		 7513 OP *kid = cLISTOPo->op_first;
7514
7515 if (kid->op_type == OP_NULL)
7516 kid = kid->op_sibling;
7517 if (kid)
7518 kid->op_flags |= OPf_MOD;
7519
7520 }
7521 return o;
7522}
7523
61b743bb
DM		 7524/* A peephole optimizer. We visit the ops in the order they're to execute.
7525 * See the comments at the top of this file for more details about when
7526 * peep() is called */
463ee0b2 7527
79072805 7528void
864dbfa3 7529Perl_peep(pTHX_ register OP *o)
79072805 7530{
27da23d5 7531 dVAR;
c445ea15 7532 register OP* oldop = NULL;
2d8e6c8d 7533
2814eb74 7534 if (!o || o->op_opt)
79072805 7535 return;
a0d0e21e 7536 ENTER;
462e5cf6 7537 SAVEOP();
7766f137 7538 SAVEVPTR(PL_curcop);
a0d0e21e 7539 for (; o; o = o->op_next) {
2814eb74 7540 if (o->op_opt)
a0d0e21e 7541 break;
533c011a 7542 PL_op = o;
a0d0e21e 7543 switch (o->op_type) {
acb36ea4 7544 case OP_SETSTATE:
a0d0e21e
LW		 7545 case OP_NEXTSTATE:
7546 case OP_DBSTATE:
3280af22 7547 PL_curcop = ((COP*)o); /* for warnings */
2814eb74 7548 o->op_opt = 1;
a0d0e21e
LW		 7549 break;
7550
a0d0e21e 7551 case OP_CONST:
7a52d87a
GS		 7552 if (cSVOPo->op_private & OPpCONST_STRICT)
7553 no_bareword_allowed(o);
7766f137 7554#ifdef USE_ITHREADS
3848b962 7555 case OP_METHOD_NAMED:
7766f137
GS		 7556 /* Relocate sv to the pad for thread safety.
7557 * Despite being a "constant", the SV is written to,
7558 * for reference counts, sv_upgrade() etc. */
7559 if (cSVOP->op_sv) {
6867be6d 7560 const PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
330e22d5 7561 if (o->op_type == OP_CONST && SvPADTMP(cSVOPo->op_sv)) {
6a7129a1 7562 /* If op_sv is already a PADTMP then it is being used by
9a049f1c 7563 * some pad, so make a copy. */
dd2155a4
DM		 7564 sv_setsv(PAD_SVl(ix),cSVOPo->op_sv);
7565 SvREADONLY_on(PAD_SVl(ix));
6a7129a1
GS		 7566 SvREFCNT_dec(cSVOPo->op_sv);
7567 }
052ca17e
NC		 7568 else if (o->op_type == OP_CONST
7569 && cSVOPo->op_sv == &PL_sv_undef) {
7570 /* PL_sv_undef is hack - it's unsafe to store it in the
7571 AV that is the pad, because av_fetch treats values of
7572 PL_sv_undef as a "free" AV entry and will merrily
7573 replace them with a new SV, causing pad_alloc to think
7574 that this pad slot is free. (When, clearly, it is not)
7575 */
7576 SvOK_off(PAD_SVl(ix));
7577 SvPADTMP_on(PAD_SVl(ix));
7578 SvREADONLY_on(PAD_SVl(ix));
7579 }
6a7129a1 7580 else {
dd2155a4 7581 SvREFCNT_dec(PAD_SVl(ix));
6a7129a1 7582 SvPADTMP_on(cSVOPo->op_sv);
dd2155a4 7583 PAD_SETSV(ix, cSVOPo->op_sv);
9a049f1c 7584 /* XXX I don't know how this isn't readonly already. */
dd2155a4 7585 SvREADONLY_on(PAD_SVl(ix));
6a7129a1 7586 }
a0714e2c 7587 cSVOPo->op_sv = NULL;
7766f137
GS		 7588 o->op_targ = ix;
7589 }
7590#endif
2814eb74 7591 o->op_opt = 1;
07447971
GS		 7592 break;
7593
df91b2c5
AE		 7594 case OP_CONCAT:
7595 if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
7596 if (o->op_next->op_private & OPpTARGET_MY) {
7597 if (o->op_flags & OPf_STACKED) /* chained concats */
7598 goto ignore_optimization;
7599 else {
7600 /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
7601 o->op_targ = o->op_next->op_targ;
7602 o->op_next->op_targ = 0;
7603 o->op_private |= OPpTARGET_MY;
7604 }
7605 }
7606 op_null(o->op_next);
7607 }
7608 ignore_optimization:
2814eb74 7609 o->op_opt = 1;
df91b2c5 7610 break;
8990e307 7611 case OP_STUB:
54310121 7612 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
2814eb74 7613 o->op_opt = 1;
54310121 7614 break; /* Scalar stub must produce undef. List stub is noop */
8990e307 7615 }
748a9306 7616 goto nothin;
79072805 7617 case OP_NULL:
acb36ea4
GS		 7618 if (o->op_targ == OP_NEXTSTATE
7619 || o->op_targ == OP_DBSTATE
7620 || o->op_targ == OP_SETSTATE)
7621 {
3280af22 7622 PL_curcop = ((COP*)o);
acb36ea4 7623 }
dad75012
AMS		 7624 /* XXX: We avoid setting op_seq here to prevent later calls
7625 to peep() from mistakenly concluding that optimisation
7626 has already occurred. This doesn't fix the real problem,
7627 though (See 20010220.007). AMS 20010719 */
2814eb74 7628 /* op_seq functionality is now replaced by op_opt */
dad75012
AMS		 7629 if (oldop && o->op_next) {
7630 oldop->op_next = o->op_next;
7631 continue;
7632 }
7633 break;
79072805 7634 case OP_SCALAR:
93a17b20 7635 case OP_LINESEQ:
463ee0b2 7636 case OP_SCOPE:
748a9306 7637 nothin:
a0d0e21e
LW		 7638 if (oldop && o->op_next) {
7639 oldop->op_next = o->op_next;
79072805
LW		 7640 continue;
7641 }
2814eb74 7642 o->op_opt = 1;
79072805
LW		 7643 break;
7644
6a077020 7645 case OP_PADAV:
79072805 7646 case OP_GV:
6a077020 7647 if (o->op_type == OP_PADAV || o->op_next->op_type == OP_RV2AV) {
0bd48802 7648 OP* const pop = (o->op_type == OP_PADAV) ?
6a077020 7649 o->op_next : o->op_next->op_next;
a0d0e21e 7650 IV i;
f9dc862f 7651 if (pop && pop->op_type == OP_CONST &&
af5acbb4 7652 ((PL_op = pop->op_next)) &&
8990e307 7653 pop->op_next->op_type == OP_AELEM &&
a0d0e21e 7654 !(pop->op_next->op_private &
78f9721b 7655 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
fc15ae8f 7656 (i = SvIV(((SVOP*)pop)->op_sv) - CopARYBASE_get(PL_curcop))
a0d0e21e 7657 <= 255 &&
8990e307
LW		 7658 i >= 0)
7659 {
350de78d 7660 GV *gv;
af5acbb4
DM		 7661 if (cSVOPx(pop)->op_private & OPpCONST_STRICT)
7662 no_bareword_allowed(pop);
6a077020
DM		 7663 if (o->op_type == OP_GV)
7664 op_null(o->op_next);
93c66552
DM		 7665 op_null(pop->op_next);
7666 op_null(pop);
a0d0e21e
LW		 7667 o->op_flags |= pop->op_next->op_flags & OPf_MOD;
7668 o->op_next = pop->op_next->op_next;
22c35a8c 7669 o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
a0d0e21e 7670 o->op_private = (U8)i;
6a077020
DM		 7671 if (o->op_type == OP_GV) {
7672 gv = cGVOPo_gv;
7673 GvAVn(gv);
7674 }
7675 else
7676 o->op_flags |= OPf_SPECIAL;
7677 o->op_type = OP_AELEMFAST;
7678 }
7679 o->op_opt = 1;
7680 break;
7681 }
7682
7683 if (o->op_next->op_type == OP_RV2SV) {
7684 if (!(o->op_next->op_private & OPpDEREF)) {
7685 op_null(o->op_next);
7686 o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
7687 | OPpOUR_INTRO);
7688 o->op_next = o->op_next->op_next;
7689 o->op_type = OP_GVSV;
7690 o->op_ppaddr = PL_ppaddr[OP_GVSV];
8990e307 7691 }
79072805 7692 }
e476b1b5 7693 else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
551405c4 7694 GV * const gv = cGVOPo_gv;
b15aece3 7695 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX_const(GvCV(gv))) {
76cd736e 7696 /* XXX could check prototype here instead of just carping */
551405c4 7697 SV * const sv = sv_newmortal();
bd61b366 7698 gv_efullname3(sv, gv, NULL);
9014280d 7699 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
35c1215d
NC		 7700 "%"SVf"() called too early to check prototype",
7701 sv);
76cd736e
GS		 7702 }
7703 }
89de2904
AMS		 7704 else if (o->op_next->op_type == OP_READLINE
7705 && o->op_next->op_next->op_type == OP_CONCAT
7706 && (o->op_next->op_next->op_flags & OPf_STACKED))
7707 {
d2c45030
AMS		 7708 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
7709 o->op_type = OP_RCATLINE;
7710 o->op_flags |= OPf_STACKED;
7711 o->op_ppaddr = PL_ppaddr[OP_RCATLINE];
89de2904 7712 op_null(o->op_next->op_next);
d2c45030 7713 op_null(o->op_next);
89de2904 7714 }
76cd736e 7715
2814eb74 7716 o->op_opt = 1;
79072805
LW		 7717 break;
7718
a0d0e21e 7719 case OP_MAPWHILE:
79072805
LW		 7720 case OP_GREPWHILE:
7721 case OP_AND:
7722 case OP_OR:
c963b151 7723 case OP_DOR:
2c2d71f5
JH		 7724 case OP_ANDASSIGN:
7725 case OP_ORASSIGN:
c963b151 7726 case OP_DORASSIGN:
1a67a97c
SM		 7727 case OP_COND_EXPR:
7728 case OP_RANGE:
2814eb74 7729 o->op_opt = 1;
fd4d1407
IZ		 7730 while (cLOGOP->op_other->op_type == OP_NULL)
7731 cLOGOP->op_other = cLOGOP->op_other->op_next;
a2efc822 7732 peep(cLOGOP->op_other); /* Recursive calls are not replaced by fptr calls */
79072805
LW		 7733 break;
7734
79072805 7735 case OP_ENTERLOOP:
9c2ca71a 7736 case OP_ENTERITER:
2814eb74 7737 o->op_opt = 1;
58cccf98
SM		 7738 while (cLOOP->op_redoop->op_type == OP_NULL)
7739 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
79072805 7740 peep(cLOOP->op_redoop);
58cccf98
SM		 7741 while (cLOOP->op_nextop->op_type == OP_NULL)
7742 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
79072805 7743 peep(cLOOP->op_nextop);
58cccf98
SM		 7744 while (cLOOP->op_lastop->op_type == OP_NULL)
7745 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
79072805
LW		 7746 peep(cLOOP->op_lastop);
7747 break;
7748
8782bef2 7749 case OP_QR:
79072805
LW		 7750 case OP_MATCH:
7751 case OP_SUBST:
2814eb74 7752 o->op_opt = 1;
9041c2e3 7753 while (cPMOP->op_pmreplstart &&
58cccf98
SM		 7754 cPMOP->op_pmreplstart->op_type == OP_NULL)
7755 cPMOP->op_pmreplstart = cPMOP->op_pmreplstart->op_next;
a0d0e21e 7756 peep(cPMOP->op_pmreplstart);
79072805
LW		 7757 break;
7758
a0d0e21e 7759 case OP_EXEC:
2814eb74 7760 o->op_opt = 1;
041457d9
DM		 7761 if (o->op_next && o->op_next->op_type == OP_NEXTSTATE
7762 && ckWARN(WARN_SYNTAX))
7763 {
a0d0e21e 7764 if (o->op_next->op_sibling &&
20408e3c
GS		 7765 o->op_next->op_sibling->op_type != OP_EXIT &&
7766 o->op_next->op_sibling->op_type != OP_WARN &&
a0d0e21e 7767 o->op_next->op_sibling->op_type != OP_DIE) {
6867be6d 7768 const line_t oldline = CopLINE(PL_curcop);
a0d0e21e 7769
57843af0 7770 CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next));
9014280d 7771 Perl_warner(aTHX_ packWARN(WARN_EXEC),
eeb6a2c9 7772 "Statement unlikely to be reached");
9014280d 7773 Perl_warner(aTHX_ packWARN(WARN_EXEC),
cc507455 7774 "\t(Maybe you meant system() when you said exec()?)\n");
57843af0 7775 CopLINE_set(PL_curcop, oldline);
a0d0e21e
LW		 7776 }
7777 }
7778 break;
b2ffa427 7779
c750a3ec 7780 case OP_HELEM: {
e75d1f10 7781 UNOP *rop;
6d822dc4 7782 SV *lexname;
e75d1f10 7783 GV **fields;
6d822dc4 7784 SV **svp, *sv;
d5263905 7785 const char *key = NULL;
c750a3ec 7786 STRLEN keylen;
b2ffa427 7787
2814eb74 7788 o->op_opt = 1;
1c846c1f
NIS		 7789
7790 if (((BINOP*)o)->op_last->op_type != OP_CONST)
c750a3ec 7791 break;
1c846c1f
NIS		 7792
7793 /* Make the CONST have a shared SV */
7794 svp = cSVOPx_svp(((BINOP*)o)->op_last);
3049cdab 7795 if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv)) && !IS_PADCONST(sv)) {
d5263905 7796 key = SvPV_const(sv, keylen);
25716404
GS		 7797 lexname = newSVpvn_share(key,
7798 SvUTF8(sv) ? -(I32)keylen : keylen,
7799 0);
1c846c1f
NIS		 7800 SvREFCNT_dec(sv);
7801 *svp = lexname;
7802 }
e75d1f10
RD		 7803
7804 if ((o->op_private & (OPpLVAL_INTRO)))
7805 break;
7806
7807 rop = (UNOP*)((BINOP*)o)->op_first;
7808 if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
7809 break;
7810 lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
00b1698f 7811 if (!SvPAD_TYPED(lexname))
e75d1f10 7812 break;
a4fc7abc 7813 fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE);
e75d1f10
RD		 7814 if (!fields || !GvHV(*fields))
7815 break;
93524f2b 7816 key = SvPV_const(*svp, keylen);
e75d1f10
RD		 7817 if (!hv_fetch(GvHV(*fields), key,
7818 SvUTF8(*svp) ? -(I32)keylen : keylen, FALSE))
7819 {
7820 Perl_croak(aTHX_ "No such class field \"%s\" "
7821 "in variable %s of type %s",
93524f2b 7822 key, SvPV_nolen_const(lexname), HvNAME_get(SvSTASH(lexname)));
e75d1f10
RD		 7823 }
7824
6d822dc4
MS		 7825 break;
7826 }
c750a3ec 7827
e75d1f10
RD		 7828 case OP_HSLICE: {
7829 UNOP *rop;
7830 SV *lexname;
7831 GV **fields;
7832 SV **svp;
93524f2b 7833 const char *key;
e75d1f10
RD		 7834 STRLEN keylen;
7835 SVOP *first_key_op, *key_op;
7836
7837 if ((o->op_private & (OPpLVAL_INTRO))
7838 /* I bet there's always a pushmark... */
7839 || ((LISTOP*)o)->op_first->op_sibling->op_type != OP_LIST)
7840 /* hmmm, no optimization if list contains only one key. */
7841 break;
7842 rop = (UNOP*)((LISTOP*)o)->op_last;
7843 if (rop->op_type != OP_RV2HV)
7844 break;
7845 if (rop->op_first->op_type == OP_PADSV)
7846 /* @$hash{qw(keys here)} */
7847 rop = (UNOP*)rop->op_first;
7848 else {
7849 /* @{$hash}{qw(keys here)} */
7850 if (rop->op_first->op_type == OP_SCOPE
7851 && cLISTOPx(rop->op_first)->op_last->op_type == OP_PADSV)
7852 {
7853 rop = (UNOP*)cLISTOPx(rop->op_first)->op_last;
7854 }
7855 else
7856 break;
7857 }
7858
7859 lexname = *av_fetch(PL_comppad_name, rop->op_targ, TRUE);
00b1698f 7860 if (!SvPAD_TYPED(lexname))
e75d1f10 7861 break;
a4fc7abc 7862 fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE);
e75d1f10
RD		 7863 if (!fields || !GvHV(*fields))
7864 break;
7865 /* Again guessing that the pushmark can be jumped over.... */
7866 first_key_op = (SVOP*)((LISTOP*)((LISTOP*)o)->op_first->op_sibling)
7867 ->op_first->op_sibling;
7868 for (key_op = first_key_op; key_op;
7869 key_op = (SVOP*)key_op->op_sibling) {
7870 if (key_op->op_type != OP_CONST)
7871 continue;
7872 svp = cSVOPx_svp(key_op);
93524f2b 7873 key = SvPV_const(*svp, keylen);
e75d1f10
RD		 7874 if (!hv_fetch(GvHV(*fields), key,
7875 SvUTF8(*svp) ? -(I32)keylen : keylen, FALSE))
7876 {
7877 Perl_croak(aTHX_ "No such class field \"%s\" "
7878 "in variable %s of type %s",
bfcb3514 7879 key, SvPV_nolen(lexname), HvNAME_get(SvSTASH(lexname)));
e75d1f10
RD		 7880 }
7881 }
7882 break;
7883 }
7884
fe1bc4cf 7885 case OP_SORT: {
fe1bc4cf 7886 /* will point to RV2AV or PADAV op on LHS/RHS of assign */
551405c4 7887 OP *oleft;
fe1bc4cf
DM		 7888 OP *o2;
7889
fe1bc4cf 7890 /* check that RHS of sort is a single plain array */
551405c4 7891 OP *oright = cUNOPo->op_first;
fe1bc4cf
DM		 7892 if (!oright || oright->op_type != OP_PUSHMARK)
7893 break;
471178c0
NC		 7894
7895 /* reverse sort ... can be optimised. */
7896 if (!cUNOPo->op_sibling) {
7897 /* Nothing follows us on the list. */
551405c4 7898 OP * const reverse = o->op_next;
471178c0
NC		 7899
7900 if (reverse->op_type == OP_REVERSE &&
7901 (reverse->op_flags & OPf_WANT) == OPf_WANT_LIST) {
551405c4 7902 OP * const pushmark = cUNOPx(reverse)->op_first;
471178c0
NC		 7903 if (pushmark && (pushmark->op_type == OP_PUSHMARK)
7904 && (cUNOPx(pushmark)->op_sibling == o)) {
7905 /* reverse -> pushmark -> sort */
7906 o->op_private |= OPpSORT_REVERSE;
7907 op_null(reverse);
7908 pushmark->op_next = oright->op_next;
7909 op_null(oright);
7910 }
7911 }
7912 }
7913
7914 /* make @a = sort @a act in-place */
7915
7916 o->op_opt = 1;
7917
fe1bc4cf
DM		 7918 oright = cUNOPx(oright)->op_sibling;
7919 if (!oright)
7920 break;
7921 if (oright->op_type == OP_NULL) { /* skip sort block/sub */
7922 oright = cUNOPx(oright)->op_sibling;
7923 }
7924
7925 if (!oright ||
7926 (oright->op_type != OP_RV2AV && oright->op_type != OP_PADAV)
7927 || oright->op_next != o
7928 || (oright->op_private & OPpLVAL_INTRO)
7929 )
7930 break;
7931
7932 /* o2 follows the chain of op_nexts through the LHS of the
7933 * assign (if any) to the aassign op itself */
7934 o2 = o->op_next;
7935 if (!o2 || o2->op_type != OP_NULL)
7936 break;
7937 o2 = o2->op_next;
7938 if (!o2 || o2->op_type != OP_PUSHMARK)
7939 break;
7940 o2 = o2->op_next;
7941 if (o2 && o2->op_type == OP_GV)
7942 o2 = o2->op_next;
7943 if (!o2
7944 || (o2->op_type != OP_PADAV && o2->op_type != OP_RV2AV)
7945 || (o2->op_private & OPpLVAL_INTRO)
7946 )
7947 break;
7948 oleft = o2;
7949 o2 = o2->op_next;
7950 if (!o2 || o2->op_type != OP_NULL)
7951 break;
7952 o2 = o2->op_next;
7953 if (!o2 || o2->op_type != OP_AASSIGN
7954 || (o2->op_flags & OPf_WANT) != OPf_WANT_VOID)
7955 break;
7956
db7511db
DM		 7957 /* check that the sort is the first arg on RHS of assign */
7958
7959 o2 = cUNOPx(o2)->op_first;
7960 if (!o2 || o2->op_type != OP_NULL)
7961 break;
7962 o2 = cUNOPx(o2)->op_first;
7963 if (!o2 || o2->op_type != OP_PUSHMARK)
7964 break;
7965 if (o2->op_sibling != o)
7966 break;
7967
fe1bc4cf
DM		 7968 /* check the array is the same on both sides */
7969 if (oleft->op_type == OP_RV2AV) {
7970 if (oright->op_type != OP_RV2AV
7971 || !cUNOPx(oright)->op_first
7972 || cUNOPx(oright)->op_first->op_type != OP_GV
7973 || cGVOPx_gv(cUNOPx(oleft)->op_first) !=
7974 cGVOPx_gv(cUNOPx(oright)->op_first)
7975 )
7976 break;
7977 }
7978 else if (oright->op_type != OP_PADAV
7979 || oright->op_targ != oleft->op_targ
7980 )
7981 break;
7982
7983 /* transfer MODishness etc from LHS arg to RHS arg */
7984 oright->op_flags = oleft->op_flags;
7985 o->op_private |= OPpSORT_INPLACE;
7986
7987 /* excise push->gv->rv2av->null->aassign */
7988 o2 = o->op_next->op_next;
7989 op_null(o2); /* PUSHMARK */
7990 o2 = o2->op_next;
7991 if (o2->op_type == OP_GV) {
7992 op_null(o2); /* GV */
7993 o2 = o2->op_next;
7994 }
7995 op_null(o2); /* RV2AV or PADAV */
7996 o2 = o2->op_next->op_next;
7997 op_null(o2); /* AASSIGN */
7998
7999 o->op_next = o2->op_next;
8000
8001 break;
8002 }
ef3e5ea9
NC		 8003
8004 case OP_REVERSE: {
e682d7b7 8005 OP *ourmark, *theirmark, *ourlast, *iter, *expushmark, *rv2av;
ce335f37 8006 OP *gvop = NULL;
ef3e5ea9
NC		 8007 LISTOP *enter, *exlist;
8008 o->op_opt = 1;
8009
8010 enter = (LISTOP *) o->op_next;
8011 if (!enter)
8012 break;
8013 if (enter->op_type == OP_NULL) {
8014 enter = (LISTOP *) enter->op_next;
8015 if (!enter)
8016 break;
8017 }
d46f46af
NC		 8018 /* for $a (...) will have OP_GV then OP_RV2GV here.
8019 for (...) just has an OP_GV. */
ce335f37
NC		 8020 if (enter->op_type == OP_GV) {
8021 gvop = (OP *) enter;
8022 enter = (LISTOP *) enter->op_next;
8023 if (!enter)
8024 break;
d46f46af
NC		 8025 if (enter->op_type == OP_RV2GV) {
8026 enter = (LISTOP *) enter->op_next;
8027 if (!enter)
ce335f37 8028 break;
d46f46af 8029 }
ce335f37
NC		 8030 }
8031
ef3e5ea9
NC		 8032 if (enter->op_type != OP_ENTERITER)
8033 break;
8034
8035 iter = enter->op_next;
8036 if (!iter || iter->op_type != OP_ITER)
8037 break;
8038
ce335f37
NC		 8039 expushmark = enter->op_first;
8040 if (!expushmark || expushmark->op_type != OP_NULL
8041 || expushmark->op_targ != OP_PUSHMARK)
8042 break;
8043
8044 exlist = (LISTOP *) expushmark->op_sibling;
ef3e5ea9
NC		 8045 if (!exlist || exlist->op_type != OP_NULL
8046 || exlist->op_targ != OP_LIST)
8047 break;
8048
8049 if (exlist->op_last != o) {
8050 /* Mmm. Was expecting to point back to this op. */
8051 break;
8052 }
8053 theirmark = exlist->op_first;
8054 if (!theirmark || theirmark->op_type != OP_PUSHMARK)
8055 break;
8056
c491ecac 8057 if (theirmark->op_sibling != o) {
ef3e5ea9
NC		 8058 /* There's something between the mark and the reverse, eg
8059 for (1, reverse (...))
8060 so no go. */
8061 break;
8062 }
8063
c491ecac
NC		 8064 ourmark = ((LISTOP *)o)->op_first;
8065 if (!ourmark || ourmark->op_type != OP_PUSHMARK)
8066 break;
8067
ef3e5ea9
NC		 8068 ourlast = ((LISTOP *)o)->op_last;
8069 if (!ourlast || ourlast->op_next != o)
8070 break;
8071
e682d7b7
NC		 8072 rv2av = ourmark->op_sibling;
8073 if (rv2av && rv2av->op_type == OP_RV2AV && rv2av->op_sibling == 0
8074 && rv2av->op_flags == (OPf_WANT_LIST | OPf_KIDS)
8075 && enter->op_flags == (OPf_WANT_LIST | OPf_KIDS)) {
8076 /* We're just reversing a single array. */
8077 rv2av->op_flags = OPf_WANT_SCALAR | OPf_KIDS | OPf_REF;
8078 enter->op_flags |= OPf_STACKED;
8079 }
8080
ef3e5ea9
NC		 8081 /* We don't have control over who points to theirmark, so sacrifice
8082 ours. */
8083 theirmark->op_next = ourmark->op_next;
8084 theirmark->op_flags = ourmark->op_flags;
ce335f37 8085 ourlast->op_next = gvop ? gvop : (OP *) enter;
ef3e5ea9
NC		 8086 op_null(ourmark);
8087 op_null(o);
8088 enter->op_private |= OPpITER_REVERSED;
8089 iter->op_private |= OPpITER_REVERSED;
8090
8091 break;
8092 }
e26df76a
NC		 8093
8094 case OP_SASSIGN: {
8095 OP *rv2gv;
8096 UNOP *refgen, *rv2cv;
8097 LISTOP *exlist;
8098
8099 /* I do not understand this, but if o->op_opt isn't set to 1,
8100 various tests in ext/B/t/bytecode.t fail with no readily
8101 apparent cause. */
8102
8103 o->op_opt = 1;
8104
de3370bc
NC		 8105
8106 if ((o->op_flags && OPf_WANT) != OPf_WANT_VOID)
8107 break;
8108
e26df76a
NC		 8109 if ((o->op_private & ~OPpASSIGN_BACKWARDS) != 2)
8110 break;
8111
8112 rv2gv = ((BINOP *)o)->op_last;
8113 if (!rv2gv || rv2gv->op_type != OP_RV2GV)
8114 break;
8115
8116 refgen = (UNOP *)((BINOP *)o)->op_first;
8117
8118 if (!refgen || refgen->op_type != OP_REFGEN)
8119 break;
8120
8121 exlist = (LISTOP *)refgen->op_first;
8122 if (!exlist || exlist->op_type != OP_NULL
8123 || exlist->op_targ != OP_LIST)
8124 break;
8125
8126 if (exlist->op_first->op_type != OP_PUSHMARK)
8127 break;
8128
8129 rv2cv = (UNOP*)exlist->op_last;
8130
8131 if (rv2cv->op_type != OP_RV2CV)
8132 break;
8133
8134 assert ((rv2gv->op_private & OPpDONT_INIT_GV) == 0);
8135 assert ((o->op_private & OPpASSIGN_CV_TO_GV) == 0);
8136 assert ((rv2cv->op_private & OPpMAY_RETURN_CONSTANT) == 0);
8137
8138 o->op_private |= OPpASSIGN_CV_TO_GV;
8139 rv2gv->op_private |= OPpDONT_INIT_GV;
8140 rv2cv->op_private |= OPpMAY_RETURN_CONSTANT;
8141
8142 break;
8143 }
8144
fe1bc4cf 8145
79072805 8146 default:
2814eb74 8147 o->op_opt = 1;
79072805
LW		 8148 break;
8149 }
a0d0e21e 8150 oldop = o;
79072805 8151 }
a0d0e21e 8152 LEAVE;
79072805 8153}
beab0874 8154
1cb0ed9b
RGS		 8155char*
8156Perl_custom_op_name(pTHX_ const OP* o)
53e06cf0 8157{
97aff369 8158 dVAR;
e1ec3a88 8159 const IV index = PTR2IV(o->op_ppaddr);
53e06cf0
SC		 8160 SV* keysv;
8161 HE* he;
8162
8163 if (!PL_custom_op_names) /* This probably shouldn't happen */
27da23d5 8164 return (char *)PL_op_name[OP_CUSTOM];
53e06cf0
SC		 8165
8166 keysv = sv_2mortal(newSViv(index));
8167
8168 he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0);
8169 if (!he)
27da23d5 8170 return (char *)PL_op_name[OP_CUSTOM]; /* Don't know who you are */
53e06cf0
SC		 8171
8172 return SvPV_nolen(HeVAL(he));
8173}
8174
1cb0ed9b
RGS		 8175char*
8176Perl_custom_op_desc(pTHX_ const OP* o)
53e06cf0 8177{
97aff369 8178 dVAR;
e1ec3a88 8179 const IV index = PTR2IV(o->op_ppaddr);
53e06cf0
SC		 8180 SV* keysv;
8181 HE* he;
8182
8183 if (!PL_custom_op_descs)
27da23d5 8184 return (char *)PL_op_desc[OP_CUSTOM];
53e06cf0
SC		 8185
8186 keysv = sv_2mortal(newSViv(index));
8187
8188 he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0);
8189 if (!he)
27da23d5 8190 return (char *)PL_op_desc[OP_CUSTOM];
53e06cf0
SC		 8191
8192 return SvPV_nolen(HeVAL(he));
8193}
19e8ce8e 8194
beab0874
JT		 8195#include "XSUB.h"
8196
8197/* Efficient sub that returns a constant scalar value. */
8198static void
acfe0abc 8199const_sv_xsub(pTHX_ CV* cv)
beab0874 8200{
97aff369 8201 dVAR;
beab0874 8202 dXSARGS;
9cbac4c7 8203 if (items != 0) {
bb263b4e 8204 /*EMPTY*/;
9cbac4c7
DM		 8205#if 0
8206 Perl_croak(aTHX_ "usage: %s::%s()",
bfcb3514 8207 HvNAME_get(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)));
9cbac4c7
DM		 8208#endif
8209 }
9a049f1c 8210 EXTEND(sp, 1);
0768512c 8211 ST(0) = (SV*)XSANY.any_ptr;
beab0874
JT		 8212 XSRETURN(1);
8213}
4946a0fa
NC		 8214
8215/*
8216 * Local variables:
8217 * c-indentation-style: bsd
8218 * c-basic-offset: 4
8219 * indent-tabs-mode: t
8220 * End:
8221 *
37442d52
RGS		 8222 * ex: set ts=8 sts=4 sw=4 noet:
8223 */
Unnamed repository; edit this file 'description' to name the repository.