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