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