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