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