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